mptcp-pm 0.0.1 → 0.0.2
raw patch · 13 files changed
+1340/−918 lines, 13 filesdep +aeson-extradep +aeson-prettydep +filepathdep −HUnitdep ~netlinknew-component:exe:mptcp-pm
Dependencies added: aeson-extra, aeson-pretty, filepath, hslogger, temporary, text, unordered-containers
Dependencies removed: HUnit
Dependency ranges changed: netlink
Files
- CHANGELOG +4/−1
- Net/IPAddress.hs +23/−38
- Net/Mptcp.hs +234/−127
- Net/Mptcp/PathManager.hs +202/−0
- Net/Mptcp/PathManager/Default.hs +71/−0
- Net/SockDiag.hs +106/−105
- Net/Tcp.hs +14/−4
- README.md +54/−13
- hs/daemon.hs +571/−348
- hs/monitor.hs +0/−68
- hs/test.hs +0/−65
- mptcp-pm.cabal +61/−63
- test/Main.hs +0/−86
CHANGELOG view
@@ -1,3 +1,6 @@-v0.0.1:++0.0.2-dev:++0.0.1: - addition of 100s of bugs - will mess up your mind
Net/IPAddress.hs view
@@ -13,8 +13,10 @@ import Net.IPv6 import Data.Serialize.Get import Data.Serialize.Put-import Data.Word (Word32)+-- import Data.Word (Word32) import Data.ByteString (ByteString)+-- import Data.Either (fromRight)+import System.Linux.Netlink.Constants as NLC -- for replicateM import Control.Monad@@ -22,52 +24,36 @@ -- check ip link / localhost seems to be 1 -- global interface index-localhostIntfIdx :: Word32-localhostIntfIdx = 1----- then I could do encode myIP--- instance Convertable IP where--- getPut = putIPAddress--- getGet _ = getIPAddress+-- TODO should remove+-- localhostIntfIdx :: Word32+-- localhostIntfIdx = 1 --- TODO I could use Serialize for IP instead--- instance Serialize IP where+-- TODO should consult+-- getInterfaceIdFromIP :: IP -> Word32+-- getInterfaceIdFromIP ip =+-- 1 getIPv4FromByteString :: ByteString -> Either String IPv4 getIPv4FromByteString val = runGet (Net.IPv4.fromOctets <$> getWord8 <*> getWord8 <*> getWord8 <*> getWord8) val +-- |+getIPFromByteString :: NLC.AddressFamily -> ByteString -> Either String IP+getIPFromByteString addrFamily ipBstr+ | addrFamily == eAF_INET = fromIPv4 <$> getIPv4FromByteString ipBstr+ | addrFamily == eAF_INET6 = fromIPv6 <$> getIPv6FromByteString ipBstr+ | otherwise = error $ "unsupported addrFamily " ++ show addrFamily++ getIPv6FromByteString :: ByteString -> Either String IPv6 getIPv6FromByteString bs =- -- returns a list to me- -- <$> replicateM 16 (getWord8) in- -- TODO check ? let val = Net.IPv6.fromWord32s <$> getWord32be <*> getWord32be <*> getWord32be <*> getWord32be in runGet val bs --- TODO pass the type ?--- getIPAddressFromByteString :: ByteString -> Maybe IP--- getIPAddressFromByteString bstr =--- let--- -- val = (fromOctets <$> getWord8 <*> getWord8 <*> getWord8 <*> getWord8)--- -- probably could use Word32 instead ?--- in--- case runGet val bstr of--- Left err -> error "maybe it was an ipv6"--- Right ip -> Just $ fromIPv4 ip- --- -- fromIPv6 c ---- big endian for IDiag--- replicateM 4 (putWord32be $ dst cust) -- dest--- assuming it's an ipv4--- valid for the ip v 4 only--- one constructor is getIPv4 :: Word32 putIPAddress :: IP -> Put putIPAddress addr = case_ putIPv4Address putIPv6Address addr@@ -88,14 +74,13 @@ putIPv4Address addr = let w32 = getIPv4 addr- -- (ip1, ip2, ip3, ip4) = toOctets $ addr in do putWord32be w32- -- mapM_ putWord8 t- -- putWord8 ip1- -- putWord8 ip2- -- putWord8 ip3- -- putWord8 ip4 replicateM_ 3 (putWord32be 0) +getAddressFamily :: IP -> AddressFamily+getAddressFamily = case_ (const eAF_INET) (const eAF_INET6)++-- isIPv6 :: IP -> Bool+-- isIPv6 = case_ (const False) (const True)
Net/Mptcp.hs view
@@ -5,12 +5,13 @@ Stability : testing Portability : Linux +OverloadedStrings allows Aeson to convert -} {-# LANGUAGE DeriveGeneric #-}+{-# LANGUAGE OverloadedStrings #-} module Net.Mptcp where -import Generated import Net.SockDiag () import Control.Exception (assert) @@ -37,6 +38,10 @@ import Net.IPAddress 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@@ -48,61 +53,133 @@ instance Show MptcpSocket where show sock = let (MptcpSocket nlSock fid) = sock in ("Mptcp netlink socket: " ++ show fid) --- isIPv4address--- |Data to hold subflows information--- use http://hackage.haskell.org/package/data-default-0.5.3/docs/Data-Default.html--- data default to provide default values---- prevents hie from working correctly ?!--- instance Default TcpConnection where--- def = TcpConnection {--- srcIp = fromIPv4 Net.IPv4.localhost--- , dstIp = fromIPv4 Net.IPv4.localhost--- , srcPort = 0--- , dstPort = 0--- , priority = Nothing--- , localId = 0--- , remoteId = 0--- , inetFamily = eAF_INET--- , subflowInterface = Nothing--- }-- type MptcpPacket = GenlPacket NoData +-- |Same as SockDiagMetrics+-- data SubflowWithMetrics = SubflowWithMetrics {+-- subflowSubflow :: TcpConnection+-- -- for now let's retain DiagTcpInfo only+-- , metrics :: [SockDiagExtension]+-- } -- |Data to hold MPTCP level information+-- TODO use Data.Set data MptcpConnection = MptcpConnection { connectionToken :: MptcpToken- , subflows :: [TcpConnection]- , localIds :: [Word8] -- ^ Announced addresses- , remoteIds :: [Word8] -- ^ Announced addresses+ -- 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 } deriving (Show, Generic) +-- | Remote port+data RemoteId = RemoteId { + remoteAddress :: IP+ , remotePort :: Word16+}+++-- 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+ SubflowDestAddress destIp = ipFromAttributes False attrs++ -- (SubflowDestPort dport) = fromJust $ makeAttributeFromMaybe MPTCP_ATTR_DPORT attrs+ in+ RemoteId destIp dport++-- we don't really care instance FromJSON MptcpConnection-instance ToJSON MptcpConnection +-- | export to the format expected by mptcpnumerics+-- could be automatically generated ?+-- toJSON :: MptcpConnection -> Value+instance ToJSON MptcpConnection where+ toJSON mptcpConn = object+ [ "name" .= toJSON (show $ connectionToken mptcpConn)+ , "sender" .= object [+ -- TODO here we could read from sysctl ? or use another SockDiagExtension+ "snd_buffer" .= toJSON (40 :: Int)+ , "capabilities" .= object []+ ]+ , "capabilities" .= object ([])+ -- TODO generated somewhere else+ -- , "subflows" .= object ([])+ ] --- TODO add to localIds++--+-- 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 subflow =- mptcpConn {- subflows = subflow : subflows mptcpConn- , localIds = localId subflow : localIds mptcpConn- , remoteIds = remoteId subflow : remoteIds mptcpConn- }+mptcpConnAddSubflow mptcpConn sf =+ -- trace ("Adding subflow" ++ show sf)+ mptcpConnAddLocalId+ (mptcpConnAddRemoteId+ -- (mptcpConn { subflows = sf : subflows mptcpConn })+ (mptcpConn { subflows = Set.insert sf (subflows mptcpConn) })+ (remoteId sf)+ )+ (localId sf) + -- , localIds = Set.insert (localId sf) (localIds mptcpConn)+ -- , remoteIds = Set.insert (remoteId sf) (remoteIds mptcpConn)+ -- }+++-- |Add local id mptcpConnAddLocalId :: MptcpConnection- -> Word8 -- ^ Local id to add+ -> Word8 -- ^Local id to add -> MptcpConnection-mptcpConnAddLocalId con locId = undefined+mptcpConnAddLocalId con locId = con { localIds = Set.insert (locId) (localIds con) } --- TODO remove subflow+-- |Add remote id+-- Le remote id doit etre associee a une addresse / TODO test protocol+mptcpConnAddRemoteId :: MptcpConnection+ -> Word8 -- ^Remote id to add+ -> MptcpConnection+mptcpConnAddRemoteId con remId = con { localIds = Set.insert (remId) (remoteIds con) }++-- |Remove subflow from an MPTCP connection mptcpConnRemoveSubflow :: MptcpConnection -> TcpConnection -> MptcpConnection-mptcpConnRemoveSubflow mptcpConn subflow = undefined+mptcpConnRemoveSubflow con sf = con {+ subflows = Set.delete sf (subflows con)+ -- TODO remove associated local/remote Id ?+} + getPort :: ByteString -> Word16 getPort val = case (runGet getWord16host val) of@@ -110,13 +187,22 @@ Right port -> port +--+-- 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+ 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+ pkt { packetHeader = myHeader } --- TODO merge default attributes--- todo pass a list of (Int, Bytestring) and build the map with fromList ?+ {-| Generates an Mptcp netlink request+TODO we could fake the Word16/Flag and -}-genMptcpRequest :: Word16 -- ^ the family id+genMptcpRequest :: Word16 -- ^the family id -> MptcpGenlEvent -- ^The MPTCP command -> Bool -- ^Dump answer (returns EOPNOTSUPP if not possible) -- -> Attributes@@ -124,8 +210,6 @@ -> MptcpPacket genMptcpRequest fid cmd dump attrs = let- -- The message type/ flag / sequence number / pid (0 => from the kernel)- -- https://elixir.bootlin.com/linux/latest/source/include/uapi/linux/netlink.h#L54 myHeader = Header (fromIntegral fid) (flags .|. fNLM_F_ACK) 0 0 geheader = GenlHeader word8Cmd mptcpGenlVer flags = if dump then fNLM_F_REQUEST .|. fNLM_F_MATCH .|. fNLM_F_ROOT else fNLM_F_REQUEST@@ -150,17 +234,10 @@ Nothing -> error "Missing locator id" Just val -> case runGet getWord8 val of -- TODO generate an error here !- Left _ -> 0+ Left _ -> error "Could not get locId !!" Right locId -> locId -- runGet getWord8 val --- inspectResult :: MyState -> Either String MptcpPacket -> IO()--- inspectResult myState result = case result of--- Left ex -> putStrLn $ "An error in parsing happened" ++ show ex--- -- Right myPack -> dispatchPacket myState myPack >> putStrLn "Valid packet"--- Right myPack -> putStrLn "inspect result Valid packet"-- -- doDumpLoop :: MyState -> IO MyState -- doDumpLoop myState = do -- let (MptcpSocket simpleSock fid) = socket myState@@ -171,25 +248,26 @@ -- return newState -data MptcpAttributes = MptcpAttributes {- connToken :: Word32- , localLocatorID :: Maybe Word8- , remoteLocatorID :: Maybe Word8- , family :: Word16 -- Remove ?- -- |Pointer to the Attributes map used to build this struct. This is purely- -- |for forward compat, please file a feature report if you have to use this.- , staSelf :: Attributes-} deriving (Show, Eq, Read)+-- data MptcpAttributes = MptcpAttributes {+-- connToken :: Word32+-- , localLocatorID :: Maybe Word8+-- , remoteLocatorID :: Maybe Word8+-- , family :: Word16 -- Remove ?+-- -- |Pointer to the Attributes map used to build this struct. This is purely+-- -- |for forward compat, please file a feature report if you have to use this.+-- , staSelf :: Attributes+-- } deriving (Show, Eq, Read) -- Wouldn't it be easier to work with ? -- data MptcpEvent = NewConnection { -- } +-- |Represents every possible setting sent/received on the netlink channel data MptcpAttribute = MptcpAttrToken MptcpToken | -- v4 or v6, AddressFamily is a netlink def- SubflowFamily AddressFamily |+ SubflowFamily AddressFamily | -- ^ should be Word16 too -- remote/local ? RemoteLocatorId Word8 | LocalLocatorId Word8 |@@ -233,43 +311,52 @@ genV6SubflowAddress :: MptcpAttr -> IPv6 -> (Int, ByteString) genV6SubflowAddress addr = undefined--- (fromEnum MPTCP_ATTR_SADDR6, runPut $ putIPAddress addr) mptcpListToAttributes :: [MptcpAttribute] -> Attributes-mptcpListToAttributes attrs = Map.fromList $map attrToPair attrs+mptcpListToAttributes attrs = Map.fromList $Prelude.map attrToPair attrs +-- |Retreive IP+-- TODO could check/use addressfamily as well+ipFromAttributes :: Bool -- ^True if source+ -> Attributes -> MptcpAttribute+ipFromAttributes True attrs =+ case makeAttributeFromMaybe MPTCP_ATTR_SADDR4 attrs of+ Just ip -> ip+ Nothing -> case makeAttributeFromMaybe MPTCP_ATTR_SADDR6 attrs of+ Just ip -> ip+ Nothing -> error "could not get the src IP"++ipFromAttributes False attrs =+ case makeAttributeFromMaybe MPTCP_ATTR_DADDR4 attrs of+ Just ip -> ip+ Nothing -> case makeAttributeFromMaybe MPTCP_ATTR_DADDR6 attrs of+ Just ip -> ip+ Nothing -> error "could not get dest IP"+ -- mptcpAttributesToMap :: [MptcpAttribute] -> Attributes -- mptcpAttributesToMap attrs = -- Map.fromList $map mptcpAttributeToTuple attrs +-- |Converts / should be a maybe ? -- TODO simplify subflowFromAttributes :: Attributes -> TcpConnection subflowFromAttributes attrs =- -- makeAttribute Int ByteString let -- expects a ByteString- (SubflowSourcePort sport) = fromJust $ makeAttributeFromMaybe MPTCP_ATTR_SPORT attrs- (SubflowDestPort dport) = fromJust $ makeAttributeFromMaybe MPTCP_ATTR_DPORT attrs- SubflowSourceAddress _srcIp = case makeAttributeFromMaybe MPTCP_ATTR_SADDR4 attrs of- Just ip -> ip- Nothing -> case makeAttributeFromMaybe MPTCP_ATTR_SADDR6 attrs of- Just ip -> ip- Nothing -> error "could not get the src IP"- SubflowDestAddress _dstIp = case makeAttributeFromMaybe MPTCP_ATTR_DADDR4 attrs of- Just ip -> ip- Nothing -> case makeAttributeFromMaybe MPTCP_ATTR_DADDR6 attrs of- Just ip -> ip- Nothing -> error "could not get the dest IP"- (LocalLocatorId lid) = fromJust $ makeAttributeFromMaybe MPTCP_ATTR_LOC_ID attrs- (RemoteLocatorId rid) = fromJust $ makeAttributeFromMaybe MPTCP_ATTR_REM_ID attrs- (SubflowInterface intfId) = fromJust $ makeAttributeFromMaybe MPTCP_ATTR_IF_IDX attrs- sfFamily = getPort $ fromJust (Map.lookup (fromEnum MPTCP_ATTR_FAMILY) attrs)+ SubflowSourcePort sport = fromJust $ makeAttributeFromMaybe MPTCP_ATTR_SPORT attrs+ SubflowDestPort dport = fromJust $ makeAttributeFromMaybe MPTCP_ATTR_DPORT attrs+ SubflowSourceAddress _srcIp = ipFromAttributes True attrs+ SubflowDestAddress _dstIp = ipFromAttributes False attrs+ LocalLocatorId lid = fromJust $ makeAttributeFromMaybe MPTCP_ATTR_LOC_ID attrs+ RemoteLocatorId rid = fromJust $ makeAttributeFromMaybe MPTCP_ATTR_REM_ID attrs+ SubflowInterface intfId = fromJust $ makeAttributeFromMaybe MPTCP_ATTR_IF_IDX attrs+ -- sfFamily = getPort $ fromJust (Map.lookup (fromEnum MPTCP_ATTR_FAMILY) attrs) prio = Nothing -- (SubflowPriority N) in- TcpConnection _srcIp _dstIp sport dport prio lid rid eAF_INET (Just intfId)+ -- TODO fix sfFamily+ TcpConnection _srcIp _dstIp sport dport prio lid rid (Just intfId) --- makeSubflowFromAttributes :: -- TODO prefix with 'e' for enum -- Map.lookup (fromEnum attr) m@@ -292,16 +379,31 @@ e2M (Right x) = Just x e2M _ = Nothing --- makeAttributeFromMap ::+-- 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 --- makeAttributeFromList ::+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 -- TODO rename fromMap makeAttributeFromMaybe :: MptcpAttr -> Attributes -> Maybe MptcpAttribute makeAttributeFromMaybe attrType attrs = let res = Map.lookup (fromEnum attrType) attrs in case res of- Nothing -> Nothing+ Nothing -> error $ "Could not build attr " ++ show attrType Just bytestring -> makeAttribute (fromEnum attrType) bytestring -- | Builds an MptcpAttribute from@@ -311,7 +413,12 @@ makeAttribute i val = case toEnum i of MPTCP_ATTR_TOKEN -> Just (MptcpAttrToken $ readToken $ Just val)- MPTCP_ATTR_FAMILY -> Just (SubflowFamily $ eAF_INET)+ -- TODO fix+ MPTCP_ATTR_FAMILY ->+ case runGet getWord16host val of+ -- assert it's eAF_INET or eAF_INET6+ Right x -> Just $ SubflowFamily (toEnum ( fromIntegral x :: Int))+ _ -> Nothing MPTCP_ATTR_SADDR4 -> SubflowSourceAddress <$> fromIPv4 <$> e2M ( getIPv4FromByteString val) MPTCP_ATTR_DADDR4 -> SubflowDestAddress <$> fromIPv4 <$> e2M (getIPv4FromByteString val) MPTCP_ATTR_SADDR6 -> SubflowSourceAddress <$> fromIPv6 <$> e2M (getIPv6FromByteString val)@@ -320,11 +427,12 @@ MPTCP_ATTR_DPORT -> SubflowDestPort <$> port where port = e2M $ runGet getWord16host val MPTCP_ATTR_LOC_ID -> Just (LocalLocatorId $ readLocId $ Just val ) MPTCP_ATTR_REM_ID -> Just (RemoteLocatorId $ readLocId $ Just val )- MPTCP_ATTR_IF_IDX ->+ MPTCP_ATTR_IF_IDX -> trace ("if_idx: " ++ show val) ( case runGet getWord32be val of Right x -> Just $ SubflowInterface x- _ -> Nothing- MPTCP_ATTR_BACKUP -> trace "makeAttribute BACKUP" Nothing+ _ -> Nothing)+ -- backup is u8+ MPTCP_ATTR_BACKUP -> Just (SubflowBackup $ readLocId $ Just val ) MPTCP_ATTR_ERROR -> trace "makeAttribute ERROR" Nothing MPTCP_ATTR_TIMEOUT -> undefined MPTCP_ATTR_CWND -> undefined@@ -334,8 +442,6 @@ dumpAttribute :: Int -> ByteString -> String dumpAttribute attrId value =- -- TODO replace with makeAttribute followd by show ?- -- traceShowId show $ makeAttribute attrId value checkIfSocketExistsPkt :: Word16 -> [MptcpAttribute] -> MptcpPacket@@ -349,6 +455,7 @@ -> Bool isAttribute ref toCompare = fst (attrToPair toCompare) == fst (attrToPair ref) +-- create a fake LocalLocatorId hasLocAddr :: [MptcpAttribute] -> Bool hasLocAddr attrs = Prelude.any (isAttribute (LocalLocatorId 0)) attrs @@ -358,6 +465,7 @@ -- need to prepare a request -- type GenlPacket a = Packet (GenlData a) -- REQUIRES: LOC_ID / TOKEN+-- TODO pass TcpConnection resetConnectionPkt :: MptcpSocket -> [MptcpAttribute] -> MptcpPacket resetConnectionPkt (MptcpSocket sock fid) attrs = let cmd = MPTCP_CMD_REMOVE@@ -365,54 +473,53 @@ 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 $ eAF_INET -- inetFamily con- , SubflowDestAddress $ dstIp con- , SubflowDestPort $ dstPort con- , SubflowInterface localhostIntfIdx- -- https://github.com/multipath-tcp/mptcp/issues/338- , SubflowSourceAddress $ srcIp con- ]----- TODO pass a TcpConnection instead ?-capCwndAttrs :: MptcpToken -> TcpConnection -> Word32 -> [MptcpAttribute]-capCwndAttrs token sf cwnd = let- capSubflowAttrs = [- MptcpAttrToken token- , SubflowMaxCwnd cwnd- -- This should not be necessary anymore ?- , SubflowSourcePort $ srcPort sf- ] ++ (subflowAttrs sf)- in- capSubflowAttrs+ LocalLocatorId $ localId con+ , RemoteLocatorId $ remoteId con+ -- TODO adapt+ , SubflowFamily $ getAddressFamily (dstIp con)+ , SubflowDestAddress $ dstIp con+ , SubflowDestPort $ dstPort con+ -- should fail if doesn't exist+ , SubflowInterface $ fromJust $ subflowInterface con+ -- https://github.com/multipath-tcp/mptcp/issues/338+ , SubflowSourceAddress $ srcIp con+ , SubflowSourcePort $ srcPort con+ ] -capCwndPkt :: MptcpSocket -> [MptcpAttribute] -> MptcpPacket-capCwndPkt (MptcpSocket sock fid) attrs =+-- |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 = assert (hasFamily attrs) pkt where- pkt = genMptcpRequest fid MPTCP_CMD_SND_CLAMP_WINDOW False attrs- -- attrs = [- -- MptcpAttrToken token- -- , SubflowFamily eAF_INET- -- , LocalLocatorId 0- -- -- TODO check emote locator ?- -- , RemoteLocatorId 0- -- , SubflowInterface localhostIntfIdx- -- -- , SubflowInterface localhostIntfIdx- -- ]- -- putStrLn "while waiting for a real implementation"+ 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 ]+ ++ subflowAttrs sf ++connectionAttrs :: MptcpConnection -> [MptcpAttribute]+connectionAttrs con = [ MptcpAttrToken $ connectionToken con ]+ -- sport/backup/intf are optional -- family /loc id/remid/daddr/dport -- TODO pass new subflow ?-newSubflowPkt :: MptcpSocket -> [MptcpAttribute] -> MptcpPacket-newSubflowPkt (MptcpSocket sock fid) attrs = let+-- should get rid of MptcpSocket [MptcpAttribute] ->+newSubflowPkt :: MptcpSocket -> MptcpConnection -> TcpConnection -> MptcpPacket+newSubflowPkt (MptcpSocket sock 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
+ Net/Mptcp/PathManager.hs view
@@ -0,0 +1,202 @@+{-+Trying to come up with a userspace abstraction for MPTCP path management++The default should deal++-- Need to deal with change in interface+-}+-- There should be+-- OnInterfaceChange+++-- we should have a list of Interfaces as well+--class PathManager a where+-- -- when a new master connection is established+-- --+-- onMasterEstablishement MptcpConnection [NetworkInterface]++module Net.Mptcp.PathManager (+ PathManager (..)+ , NetworkInterface(..)+ , AvailablePaths+ , mapIPtoInterfaceIdx+ -- TODO don't export / move to its own file+ , handleAddr+ , globalInterfaces+) where++import Prelude hiding (concat, init)++import Net.Mptcp+import Net.IP+import Data.Word (Word32)+import qualified Data.Map as Map+import qualified System.Linux.Netlink.Route as NLR+import System.Linux.Netlink as NL+import Debug.Trace+import Control.Concurrent+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)+import Data.ByteString.Char8 (unpack, init)+import Data.Maybe (fromMaybe)+import System.IO.Unsafe+import Net.IPAddress++{-# NOINLINE globalInterfaces #-}+globalInterfaces :: MVar AvailablePaths+globalInterfaces = unsafePerformIO newEmptyMVar+++interfacesToIgnore :: [String]+interfacesToIgnore = [+ "virbr0"+ , "virbr1"+ , "nlmon0"+ , "ppp0"+ , "lo"+ ]++-- basically a retranscription of NLR.NAddrMsg+-- TODO add flags ?+data NetworkInterface = NetworkInterface {+ ipAddress :: IP, -- ^ Should be a list or a set+ interfaceName :: String, -- ^ eth0 / ppp0+ interfaceId :: Word32 -- ^ refers to addrInterfaceIndex+} deriving Show++++-- [NetworkInterface]+type AvailablePaths = Map.Map IP NetworkInterface++++-- |+mapIPtoInterfaceIdx :: AvailablePaths -> IP -> Maybe Word32+mapIPtoInterfaceIdx paths ip =+ interfaceId <$> Map.lookup ip paths++-- class AvailableIPsContainer a where+++-- |Reimplements+-- TODO we should not need the socket+-- onMasterEstablishement +data PathManager = PathManager {+ name :: String+ -- interfacesToIgnore :: [String]+ , onMasterEstablishement :: MptcpSocket -> MptcpConnection -> AvailablePaths -> [MptcpPacket]+ -- , onAddrChange ++ -- should list advertised IPs+}++-- } deriving PathManager+++-- TODO we should use the+handleInterfaceNotification+ :: AddressFamily -> Attributes -> Word32 -> Maybe NetworkInterface+handleInterfaceNotification addrFamily attrs addrIntf =++ -- case of+ -- Nothing -> Nothing+ -- Just val -> + -- TODO+ -- filter on flags too (UP), should be != LOOPBACK+ -- lo: <LOOPBACK,UP,LOWER_UP> and+ -- eno1: <BROADCAST,MULTICAST,UP,LOWER_UP+ case ifNameM of+ Nothing -> Nothing+ Just ifName -> case (elem ifName interfacesToIgnore ) of+ True -> Nothing+ False -> Just $ NetworkInterface ip ifName addrIntf+ where+ -- ip = undefined+ -- gets the bytestring / assume it always work+ ipBstr = fromMaybe empty (NLR.getIFAddr attrs)+ ifNameBstr = (Map.lookup NLC.eIFLA_IFNAME attrs)+ ifNameM = getString <$> ifNameBstr+ -- ip = getIPFromByteString addrFamily ipBstr+ ip = case (getIPFromByteString addrFamily ipBstr) of+ Right val -> val+ Left err -> undefined++-- taken from netlink+getString :: ByteString -> String+getString b = unpack (init b)+++-- TODO handle remove/new event move to PathManager+-- todo should be pure and let daemon+handleAddr :: Either String NLR.RoutePacket -> IO ()+handleAddr (Left errStr) = putStrLn $ "Error decoding packet: " ++ errStr+handleAddr (Right (DoneMsg hdr)) =+ putStrLn $ "Error decoding packet: " ++ show hdr+handleAddr (Right (ErrorMsg hdr errorInt errorBstr)) =+ putStrLn $ "Error decoding packet: " ++ show hdr+-- TODO need handleMessage pkt+-- family maskLen flags scope addrIntf+handleAddr (Right (Packet hdr pkt attrs)) = do+ (putStrLn $ "received packet" ++ show pkt)+ oldIntfs <- trace "taking MVAR" (takeMVar globalInterfaces)++ let toto = (case pkt of+ arg@NLR.NAddrMsg{} ->+ let resIntf = handleInterfaceNotification (NLR.addrFamily arg) attrs (NLR.addrInterfaceIndex arg)+ in case resIntf of+ Nothing -> oldIntfs+ Just newIntf -> let+ ip = ipAddress newIntf+ in if msgType == eRTM_NEWADDR+ then trace "adding ip" (Map.insert ip newIntf oldIntfs)+ -- >> putStrLn "Added interface"+ else if msgType == eRTM_GETADDR+ then trace "GET_ADDR" oldIntfs++ else if msgType == eRTM_DELADDR+ then+ trace "deleting ip" (Map.delete ip oldIntfs)+ -- >> putStrLn "Removed interface"+ else trace "other type" oldIntfs++ -- _ -> error "can't be anything else"+ arg@NLR.NNeighMsg{} -> trace "neighbor msg" oldIntfs+ arg@NLR.NLinkMsg{} -> trace "link msg" oldIntfs+ )++ trace ("putting mvar") (putMVar globalInterfaces $! (toto))++ where+ -- gets the bytestring+ msgType = messageType hdr++-- (arg@DiagTcpInfo{})+++---- Updates the list of interfaces+---- should run in background+----+--trackSystemInterfaces :: IO()+--trackSystemInterfaces = do+-- -- check routing information+-- routingSock <- NLS.makeNLHandle (const $ pure ()) =<< NL.makeSocket+-- let cb = NLS.NLCallback (pure ()) (handleAddr . runGet getGenPacket)+-- NLS.nlPostMessage routingSock queryAddrs cb+-- NLS.nlWaitCurrent routingSock+-- dumpSystemInterfaces++++-- fullmesh / ndiffports+ -- []++ -- where+ -- -- genPkt NetworkInterface+ -- -- let newSfPkt = newSubflowPkt mptcpSock newSubflowAttrs+ -- newSubflowAttrs = [+ -- MptcpAttrToken $ connectionToken con+ -- ]+ -- ++ (subflowAttrs $ masterSf { srcPort = 0 })
+ Net/Mptcp/PathManager/Default.hs view
@@ -0,0 +1,71 @@+module Net.Mptcp.PathManager.Default (+ -- TODO don't export / move to its own file+ ndiffports+ , meshPathManager+) where++import Net.Tcp+import Net.Mptcp+import Net.Mptcp.PathManager+import Data.Maybe (fromJust)+import qualified Data.Set as Set+import Debug.Trace++ndiffports :: PathManager+ndiffports = PathManager {+ name = "ndiffports"+ , onMasterEstablishement = nportsOnMasterEstablishement+}++meshPathManager :: PathManager+meshPathManager = PathManager {+ name = "mesh"+ , onMasterEstablishement = meshOnMasterEstablishement+}++++-- per interface+-- TODO check if there is already an interface with this connection+meshGenPkt :: MptcpSocket -> MptcpConnection -> NetworkInterface -> [MptcpPacket] -> [MptcpPacket]+meshGenPkt mptcpSock mptcpCon intf pkts =++ if traceShow (intf) (interfaceId intf == (fromJust $ subflowInterface masterSf)) then+ pkts+ else+ pkts ++ [newSubflowPkt mptcpSock mptcpCon generatedCon]+ where+ generatedCon = TcpConnection {+ srcPort = 0 -- let the kernel handle it+ , dstPort = dstPort masterSf+ , srcIp = ipAddress intf+ , dstIp = dstIp masterSf -- same as master+ , priority = Nothing+ -- TODO fix this+ , localId = fromIntegral $ interfaceId intf -- how to get it ? or do I generate it ?+ , remoteId = remoteId masterSf+ , subflowInterface = Just $ interfaceId intf+ }++ masterSf = Set.elemAt 0 (subflows mptcpCon)+++{-+ Generate requests+it iterates over local interfaces and try to connect+-}+meshOnMasterEstablishement :: MptcpSocket -> MptcpConnection -> AvailablePaths -> [MptcpPacket]+meshOnMasterEstablishement mptcpSock con paths = do+ foldr (meshGenPkt mptcpSock con) [] paths+++{-+ Generate requests+TODO it iterates over local interfaces but not +-}+nportsOnMasterEstablishement :: MptcpSocket -> MptcpConnection -> AvailablePaths -> [MptcpPacket]+nportsOnMasterEstablishement mptcpSock con paths = do+ foldr (meshGenPkt mptcpSock con) [] paths+ -- TODO create #X subflows+ -- iterate +
Net/SockDiag.hs view
@@ -13,19 +13,21 @@ {-# LANGUAGE DeriveGeneric #-} {-# LANGUAGE DeriveAnyClass #-} module Net.SockDiag (- InetDiagMsg (..)+ SockDiagMsg (..)+ , SockDiagExtension (..) , genQueryPacket , loadExtension , showExtension+ , connectionFromDiag ) where -- import Generated import Data.Word (Word8, Word16, Word32, Word64) -import Prelude hiding (length, concat)-import Prelude hiding (length, concat)+import Prelude hiding (length, concat, init) import Data.Maybe (fromJust)+import Data.Either (fromRight) import Data.Serialize import Data.Serialize.Get ()@@ -35,26 +37,29 @@ import System.Linux.Netlink import System.Linux.Netlink.Constants--- For TcpState, FFI generated-import Generated--- (IDiagExt, TcpState, msgTypeSockDiag) import qualified Data.Bits as B import Data.Bits ((.|.)) import qualified Data.Map as Map import Data.ByteString ()-import Data.ByteString.Char8 as C8 (unpack)+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+ -- requires cabal as a dep -- import Distribution.Utils.ShortText (decodeStringUtf8) import GHC.Generics -- iproute uses this seq number #define MAGIC_SEQ 123456+-- TODO we could remove it magicSeq :: Word32 magicSeq = 123456 @@ -65,8 +70,8 @@ -- -- |} data InetDiagSockId = InetDiagSockId {- idiag_sport :: Word16- , idiag_dport :: Word16+ idiag_sport :: Word16 -- ^Source port+ , idiag_dport :: Word16 -- ^Destination port -- Just be careful that this is a fixed size regardless of family -- __be32 idiag_src[4];@@ -75,8 +80,8 @@ , idiag_src :: ByteString , idiag_dst :: ByteString - , idiag_intf :: Word32- , idiag_cookie :: Word64+ , idiag_intf :: Word32 -- ^Interface id+ , idiag_cookie :: Word64 -- ^To specifically request an sockid } deriving (Eq, Show) @@ -89,33 +94,26 @@ shiftL :: a -> Word32 instance Enum2Bits TcpState where- -- toBits = enumsToWord shiftL state = B.shiftL 1 (fromEnum state) -instance Enum2Bits IDiagExt where- -- toBits = enumsToWord+instance Enum2Bits SockDiagExtensionId where shiftL state = B.shiftL 1 ((fromEnum state) - 1) --- instance Enum2Bits INetDiag where--- toBits = enumsToWord enumsToWord :: Enum2Bits a => [a] -> Word32 enumsToWord [] = 0 enumsToWord (x:xs) = (shiftL x) .|. (enumsToWord xs) --- TODO use bitset package ? but broken on nixos+-- TODO use bitset package ? but broken wordToEnums :: Enum2Bits a => Word32 -> [a] wordToEnums _ = [] --- defined in include/uapi/linux/inet_diag.h--- data InetDiagReq = InetDiagMsg {---- {| This generates a response of inet_diag_msg--- rename to answer ? |}-data InetDiagMsg = InetDiagMsg {- idiag_family :: Word8- , idiag_state :: Word8+{- | This generates a response of inet_diag_msg+-}+data SockDiagMsg = SockDiagMsg {+ idiag_family :: AddressFamily -- ^+ , idiag_state :: Word8 -- ^Bitfield matching the request , idiag_timer :: Word8 , idiag_retrans :: Word8 , idiag_sockid :: InetDiagSockId@@ -138,9 +136,9 @@ putStates states = putWord32host $ enumsToWord states -instance Convertable InetDiagMsg where- getPut = putInetDiagMsg- getGet _ = getInetDiagMsg+instance Convertable SockDiagMsg where+ getPut = putSockDiagMsg+ getGet _ = getSockDiagMsg -- TODO rename to a TCP one ? SockDiagRequest data SockDiagRequest = SockDiagRequest {@@ -148,7 +146,8 @@ -- It should be set to the appropriate IPPROTO_* constant for AF_INET and AF_INET6, and to 0 otherwise. , sdiag_protocol :: Word8 -- ^IPPROTO_XXX always TCP ? -- IPv4/v6 specific structure- , idiag_ext :: [IDiagExt] -- ^query extended info (word8 size)+ -- Bitset+ , idiag_ext :: [SockDiagExtensionId] -- ^query extended info (word8 size) -- , req_pad :: Word8 -- ^ padding for backwards compatibility with v1 -- in principle, any kind of state, but for now we only deal with TcpStates@@ -182,7 +181,7 @@ _sockid <- getInetDiagSockid -- TODO reestablish states return $ SockDiagRequest addressFamily protocol - (wordToEnums extended :: [IDiagExt]) (wordToEnums states :: [TcpState]) _sockid+ (wordToEnums extended :: [SockDiagExtensionId]) (wordToEnums states :: [TcpState]) _sockid -- |'Put' function for 'GenlHeader' putSockDiagRequestHeader :: SockDiagRequest -> Put@@ -198,10 +197,26 @@ putStates $ idiag_states request putInetDiagSockid $ diag_sockid request --- | +-- |Converts a generic SockDiagMsg into a TCP connection+connectionFromDiag :: SockDiagMsg+ -> TcpConnection+connectionFromDiag msg =+ let sockid = idiag_sockid msg in+ TcpConnection {+ srcIp = fromRight (error "no default") (getIPFromByteString (idiag_family msg) (idiag_src sockid))+ , dstIp = fromRight (error "no default") (getIPFromByteString (idiag_family msg) (idiag_dst sockid))+ , srcPort = idiag_sport sockid+ , dstPort = idiag_dport sockid+ , priority = Nothing+ , localId = 0+ , remoteId = 0+ , subflowInterface = Nothing+ }++-- | Serialize SockDiagMsg -- Usually accompanied with attributes ?-getInetDiagMsg :: Get InetDiagMsg-getInetDiagMsg = do+getSockDiagMsg :: Get SockDiagMsg+getSockDiagMsg = do family <- getWord8 state <- getWord8 timer <- getWord8@@ -213,11 +228,11 @@ wqueue <- getWord32host uid <- getWord32host inode <- getWord32host- return$ InetDiagMsg family state timer retrans _sockid expires rqueue wqueue uid inode+ return$ SockDiagMsg (fromIntegral family) state timer retrans _sockid expires rqueue wqueue uid inode -putInetDiagMsg :: InetDiagMsg -> Put-putInetDiagMsg msg = do- putWord8 $ idiag_family msg+putSockDiagMsg :: SockDiagMsg -> Put+putSockDiagMsg msg = do+ putWord8 $ fromIntegral $ fromEnum $ idiag_family msg putWord8 $ idiag_state msg putWord8 $ idiag_timer msg putWord8 $ idiag_retrans msg@@ -234,7 +249,6 @@ -- TODO add support for OWDs getInetDiagSockid :: Get InetDiagSockId getInetDiagSockid = do--- getWord32host sport <- getWord16host dport <- getWord16host -- iterate/ grow@@ -244,6 +258,7 @@ cookie <- getWord64host return $ InetDiagSockId sport dport _src _dst _intf cookie +-- | put addresses as bytestring since the family is not known yet putInetDiagSockid :: InetDiagSockId -> Put putInetDiagSockid cust = do -- we might need to clean up this a bit@@ -251,35 +266,11 @@ putWord16be $ idiag_dport cust putByteString (idiag_src cust) putByteString (idiag_dst cust)- -- putIPAddress (src cust)- -- putIPAddress (dst cust) putWord32host $ idiag_intf cust putWord64host $ idiag_cookie cust --- struct tcpvegas_info {--- __u32 tcpv_enabled;--- __u32 tcpv_rttcnt;--- __u32 tcpv_rtt;--- __u32 tcpv_minrtt;--- };--- data DiagVegasInfo = TcpVegasInfo {--- -- TODO hide ?--- tcpInfoVegasEnabled :: Word32--- , tcpInfoRttCount :: Word32--- , tcpInfoRtt :: Word32--- , tcpInfoMinrtt :: Word32--- } --- instance Convertable DiagVegasInfo where--- getPut = putDiagVegasInfo--- getGet _ = getDiagVegasInfo----- putDiagVegasInfo :: -> Put--- putDiagVegasInfo info = error "should not be needed"---getDiagVegasInfo :: Get IDiagExtension+getDiagVegasInfo :: Get SockDiagExtension getDiagVegasInfo = TcpVegasInfo <$> getWord32host <*> getWord32host <*> getWord32host <*> getWord32host @@ -288,14 +279,12 @@ eIPPROTO_TCP = 6 --- getTcpInfo :: Get IDiagExtension--- getTcpInfo =--- DiagTcpInfo <$> getWord8--- Word8 Word8 Word8 Word8 Word8 Word8 Word8 Word32 Word32 Word32 Word32 Word32 Word32 Word32 Word32 Word32 Word32 Word32 Word32 Word32 Word32 Word32 Word32 Word32 Word32 Word32 Word32 Word32 Word32 Word32 Word32---- TODO generate with c2hsc ?--- include/uapi/linux/inet_diag.h-data IDiagExtension = DiagTcpInfo {+{-|+Different answers described in include/uapi/linux/inet_diag.h+-}+data SockDiagExtension =+ -- | Exact copy of kernel's struct tcp_info+ DiagTcpInfo { tcpi_state :: Word8, tcpi_ca_state :: Word8, tcpi_retransmits :: Word8,@@ -334,52 +323,63 @@ tcpi_reordering :: Word32, tcpi_rcv_rtt :: Word32, tcpi_rcv_space :: Word32,- tcpi_total_retrans :: Word32+ tcpi_total_retrans :: Word32, -} | Meminfo {+ -- Extended version, hoping it doesn't break too much stuff+ tcpi_fowd :: Word32,+ tcpi_bowd :: Word32++} | DiagExtensionMemInfo { idiag_rmem :: Word32 , idiag_wmem :: Word32 , idiag_fmem :: Word32 , idiag_tmem :: Word32-} | TcpVegasInfo {--- tcpvegas_info - -- TODO hide ?+} |+ -- | Not exclusive to Vegas unlike the name indicates, mirrors tcpvegas_info+ TcpVegasInfo { tcpInfoVegasEnabled :: Word32 , tcpInfoRttCount :: Word32 , tcpInfoRtt :: Word32 , tcpInfoMinrtt :: Word32-} | CongInfo String deriving (Show, Generic)+} | CongInfo String+ | SockDiagShutdown Word8+ -- Apparently used to pass BBR data+ | SockDiagMark Word32+ deriving (Show, Generic) -- ideally we should be able to , Serialize--- encode--- instance Convertable IDiagExtension where+-- instance Convertable SockDiagExtension where -- getGet _ = get -- getPut = put --- not sure what it is--- INET_DIAG_MARK, /* only with CAP_NET_ADMIN */ -getTcpVegasInfo :: Get IDiagExtension+getTcpVegasInfo :: Get SockDiagExtension getTcpVegasInfo = TcpVegasInfo <$> getWord32host <*> getWord32host <*> getWord32host <*> getWord32host -getMemInfo :: Get IDiagExtension-getMemInfo = Meminfo <$> getWord32host <*> getWord32host <*> getWord32host <*> getWord32host+getMemInfo :: Get SockDiagExtension+getMemInfo = DiagExtensionMemInfo <$> getWord32host <*> getWord32host <*> getWord32host <*> getWord32host +getDiagMark :: Get SockDiagExtension+getDiagMark = SockDiagMark <$> getWord32host --- |-getCongInfo :: Get IDiagExtension++getShutdown :: Get SockDiagExtension+getShutdown = SockDiagShutdown <$> getWord8++-- | Get congestion control name+getCongInfo :: Get SockDiagExtension getCongInfo = do- -- bytes = getListOf getWord8 left <- remaining bs <- getByteString left- return (CongInfo $ unpack bs)+ return (CongInfo $ unpack $ init bs) --- Meminfo <$> getWord32host <*> getWord32host <*> getWord32host <*> getWord32host -getDiagTcpInfo :: Get IDiagExtension+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 -- Sends a SockDiagRequest -- expects INetDiag@@ -396,22 +396,24 @@ -- TODO if we have a cookie ignore the rest ?! -- requestedInfo = InetDiagNone -showExtension :: IDiagExtension -> String+showExtension :: SockDiagExtension -> String showExtension (CongInfo cc) = "Using CC " ++ (show cc) showExtension (TcpVegasInfo _ _ rtt minRtt) = "RTT=" ++ (show rtt) ++ " minRTT=" ++ show minRtt--- tcpi_state :: Word8, showExtension (arg@DiagTcpInfo{}) = "TcpInfo: rtt/rttvar=" ++ show ( tcpi_rtt arg) ++ "/" ++ show ( tcpi_rttvar arg) ++ " snd_cwnd/ssthresh=" ++ show (tcpi_snd_cwnd arg) ++ "/" ++ show (tcpi_snd_ssthresh arg) showExtension rest = show rest--- "RTT=" ++ (show rtt) ++ " minRTT=" ++ show minRtt --- | TODO use either ?-genQueryPacket :: (Either Word64 TcpConnection) -> [TcpState] -> [IDiagExt] -> Packet SockDiagRequest+{- Generate+ Check man sock_diag+-}+genQueryPacket :: (Either Word64 TcpConnection)+ -> [TcpState] -- ^Ignored when querying a single connection+ -> [SockDiagExtensionId] -- ^Queried values+ -> Packet SockDiagRequest genQueryPacket selector tcpStatesFilter requestedInfo = let -- Mesge type / flags /seqNum /pid flags = (fNLM_F_REQUEST .|. fNLM_F_MATCH .|. fNLM_F_ROOT) - -- might be a trick with seqnum hdr = Header msgTypeSockDiag flags magicSeq 0 @@ -430,10 +432,6 @@ in InetDiagSockId (srcPort con) (dstPort con) ipSrc ipDst (fromJust ifIndex) _cookie - -- 1 => "lo". Check with ip link ?- -- TODO pick from connection- -- ifIndex = fromIntegral localhostIntfIdx :: Word32- custom = SockDiagRequest eAF_INET eIPPROTO_TCP requestedInfo tcpStatesFilter diag_req in Packet hdr custom Map.empty@@ -443,11 +441,11 @@ queryPacketFromCookie cookie = genQueryPacket (Left cookie) [] [] -loadExtension :: Int -> ByteString -> Maybe IDiagExtension+loadExtension :: Int -> ByteString -> Maybe SockDiagExtension loadExtension key value = let+ eExtId = (toEnum key :: SockDiagExtensionId) fn = case toEnum key of -- MessageType shouldn't matter anyway ?!- -- DiagCong error too few bytes InetDiagCong -> Just getCongInfo -- InetDiagNone -> Nothing InetDiagInfo -> Just getDiagTcpInfo@@ -458,14 +456,16 @@ -- InetDiagTos -> Nothing -- InetDiagTclass -> Nothing -- InetDiagSkmeminfo -> Nothing- -- InetDiagShutdown -> Nothing+ InetDiagShutdown -> Just getShutdown+ InetDiagMeminfo -> Just getMemInfo -- InetDiagDctcpinfo -> Nothing -- InetDiagProtocol -> Nothing -- InetDiagSkv6only -> Nothing -- InetDiagLocals -> Nothing -- InetDiagPeers -> Nothing -- InetDiagPad -> Nothing- -- InetDiagMark -> Nothing+ -- requires CAP_NET_ADMIN+ InetDiagMark -> Just getDiagMark -- InetDiagBbrinfo -> Nothing -- InetDiagClassId -> Nothing -- InetDiagMd5sig -> Nothing@@ -480,5 +480,6 @@ Nothing -> Nothing Just getFn -> case runGet getFn value of Right x -> Just $ x- Left err -> error $ "Decoding error " ++ err+ Left err -> error $ "error decoding " ++ show eExtId ++ ":\n" ++ err+
Net/Tcp.hs view
@@ -10,6 +10,7 @@ module Net.Tcp ( TcpConnection (..) , Net.Tcp.reverse+ , Net.Tcp.nameFromTcpConnection ) where @@ -18,6 +19,10 @@ 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@@ -27,13 +32,19 @@ , priority :: Maybe Word8 -- ^subflow priority , localId :: Word8 -- ^ Convert to AddressFamily , remoteId :: Word8- , inetFamily :: Word16- , subflowInterface :: Maybe Word32 -- ^Interface of Maybe ?+ -- 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)+} 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@@ -44,7 +55,6 @@ , localId = remoteId con , remoteId = localId con , subflowInterface = Nothing- , inetFamily = inetFamily con }
README.md view
@@ -28,6 +28,9 @@ ``` +To compile the doc (and understand why HIE fails displaying anything)+`cabal haddock --all`+ # Usage Enter the nix-shell shell-test.nix and start the daemon:@@ -43,26 +46,64 @@ `$ nix run nixpkgs.iperf -c iperf -s` In another:-`$ nix run nixpkgs.iperf -c iperf -c localhost -b 1KiB -t 4 --cport 5500 -4`+`$ nix run nixpkgs.iperf -c iperf -c localhost -b 1KiB -t 4 --cport 5500 -4 -C+cubic` -TODO:-ss package sends by default++Script to reload module++ ```--- #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))+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"++} ```-- [ ] write wordToEnums function, especially to fix getSockDiagRequestHeader-(with bitset package once it's fixed) + # 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 -# BUGS+sudo insmod ~/mptcp/build/net/ipv4/tcp_cubic.ko -- conversion of IDiagExt is bad everywhere ? req.r.idiag_ext |= (1<<(INET_DIAG_INFO-1));-- we need to request more states+# BUGS+- conversion of SockDiagExtensionId is bad everywhere ? req.r.idiag_ext |= (1<<(INET_DIAG_INFO-1)); -# TODO +# 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-- to get kernel ifindex: cat /sys/class/net/lo/ifindex+++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))+++
hs/daemon.hs view
@@ -44,34 +44,50 @@ Useful functions in Map - member / elemes / keys / assocs / keysSet / toList -}+{-# LANGUAGE DeriveGeneric #-}+{-# LANGUAGE OverloadedStrings #-}+{-# OPTIONS_GHC -fno-warn-orphans #-} --- !/usr/bin/env nix-shell--- !nix-shell ../shell-haskell.nix -i ghc module Main where -import Prelude hiding (concat)-import Options.Applicative hiding (value, ErrorMsg)+import Prelude hiding (concat, init)+import Options.Applicative hiding (value, ErrorMsg, empty) import qualified Options.Applicative (value) -- For TcpState, FFI generated-import 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.IPAddress +import Net.SockDiag.Constants+import Net.Tcp.Constants+import Net.Mptcp.Constants+++-- for readList+import Text.Read+-- pack+import Data.Text ()+ -- for replicateM--- import Control.Monad-import Data.Maybe ()-import Data.Foldable ()+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 -- import qualified System.Linux.Netlink as NL import System.Linux.Netlink as NL import System.Linux.Netlink.GeNetlink as GENL 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.Linux.Netlink.GeNetlink.Control@@ -88,9 +104,14 @@ -- 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.Map as Map+import qualified Data.Set as Set +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@@ -100,50 +121,111 @@ -- import Control.Exception import Control.Concurrent-import Control.Exception (assert)+-- import Control.Exception (assert) -- import Control.Concurrent.Chan -- import Data.IORef -- import Control.Concurrent.Async import System.IO.Unsafe+import System.IO.Temp ()+-- for takeFilename+import System.FilePath ()++-- , Handle+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++-- 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+ , Priority(DEBUG)+ , Priority(INFO)+ , setLevel, updateGlobalLogger+ )+import System.Log.Handler.Simple (+ streamHandler+ -- , GenericHandler+ ) -- 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 ? -{-# NOINLINE globalMetricsSock #-}-globalMetricsSock :: MVar NetlinkSocket-globalMetricsSock = unsafePerformIO newEmptyMVar+-- TODO remove+-- globalMetricsSock :: MVar NetlinkSocket+-- globalMetricsSock = unsafePerformIO newEmptyMVar +-- {-# NOINLINE globalInterfaces #-}+-- globalInterfaces :: MVar AvailablePaths+-- globalInterfaces = unsafePerformIO newEmptyMVar+ iperfClientPort :: Word16 iperfClientPort = 5500 iperfServerPort :: Word16 iperfServerPort = 5201 -monitoringRateMs :: Int-monitoringRateMs = 100+-- |+onSuccessSleepingDelay :: Int+onSuccessSleepingDelay = 300 +-- When it couldn't set the correct value+onFailureSleepingDelay :: Int+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 +pathManager :: PathManager+pathManager = meshPathManager++-- |Helper to pass information across functions data MyState = MyState { socket :: MptcpSocket -- ^Socket -- ThreadId/MVar , connections :: Map.Map MptcpToken (ThreadId, MVar MptcpConnection)+ -- |Arguments passed to the program+ , cliArguments :: CLIArguments }--- deriving Show -+-- 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 --- , dstIp = fromIPv4 localhost authorizedCon1 :: TcpConnection authorizedCon1 = TcpConnection { srcIp = fromIPv4 $ Net.IPv4.ipv4 192 168 0 128@@ -154,9 +236,11 @@ , subflowInterface = Nothing , localId = 0 , remoteId = 0- , inetFamily = eAF_INET } +authorizedCon2 :: TcpConnection+authorizedCon2 = authorizedCon1 { srcIp = fromIPv4 $ Net.IPv4.ipv4 192 168 0 130 }+ filteredConnections :: [TcpConnection] filteredConnections = [ authorizedCon1@@ -187,9 +271,20 @@ -- todo use it as a filter-data Sample = Sample {+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++ -- | Folder where to log files+ , out :: FilePath+ -- , clientIP :: IPv4 , quiet :: Bool , enthusiasm :: Int@@ -199,27 +294,52 @@ -- TODO use 3rd party library levels -- data Verbosity = Normal | Debug +loggerName :: String+loggerName = "main" +dumpSystemInterfaces :: IO()+dumpSystemInterfaces = do+ putStrLn "Dumping interfaces"+ -- isEmptyMVar globalInterfaces+ res <- tryReadMVar globalInterfaces + case res of+ Nothing -> putStrLn "No interfaces"+ Just interfaces -> Prelude.print interfaces + 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 ?--- eitherReader -- ByteString--- <> ( metavar "ServerIP"---readerError-sample :: Parser Sample-sample = Sample+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+ ( long "optimizer"+ <> short 'p'+ <> help "Path to the userspace program"+ <> showDefault+ <> Options.Applicative.value "fake_solver"+ <> metavar "PROGRAM" )+ <*> strOption+ ( long "out"+ <> short 'o'+ <> help "Where to store the files"+ <> showDefault+ <> Options.Applicative.value "/tmp"+ <> metavar "PROGRAM" ) <*> switch ( long "verbose" <> short 'v'@@ -232,7 +352,7 @@ <> metavar "INT" ) -opts :: ParserInfo Sample+opts :: ParserInfo CLIArguments opts = info (sample <**> helper) ( fullDesc <> progDesc "Print a greeting for TARGET"@@ -269,7 +389,7 @@ params = proc "daemon" [ show token ] -- todo pass the token via the environment newParams = params {- -- cmdspec = RawCommand "monitor" [ show token ] + -- cmdspec = RawCommand "monitor" [ show token ] new_session = True -- cwd -- env@@ -282,156 +402,130 @@ sleepMs :: Int -> IO() sleepMs n = threadDelay (n * 1000) --- Need a specific chan--- TODO it should start a forkIO that fetches metrics and updates stuff--- Chan ->--- readChan is blocking sadly--- modifyMVar_----- here we may want to run mptcpnumerics to get some results-updateSubflowMetrics :: TcpConnection -> IO ()-updateSubflowMetrics subflow = do- putStrLn "Reading metrics sock Mvar..."- sockMetrics <- readMVar globalMetricsSock-- putStrLn "Reading mptcp sock Mvar..."- mptcpSock <- readMVar globalMptcpSock- putStrLn "Finished reading"+-- | 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]- -- let (MptcpSocket testSock familyId ) = mptcpSock sendPacket sockMetrics queryPkt putStrLn "Sent the TCP SS request" -- exported from my own version !!- recvMulti sockMetrics >>= inspectIdiagAnswers- -- for now let's discard the answer- -- recvOne sockMetrics >>= inspectIdiagAnswers+ -- TODO display number of answers+ 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" - -- let capCwndPkt = genCapCwnd familyId- -- sendPacket testSock capCwndPkt >> putStrLn "Sent the Cap command" --- TODO --- clude child configs in grub menu #45345--- send MPTCP_CMD_SND_CLAMP_WINDOW--- TODO we need the token to generate the command ?---token, family, loc_id, rem_id, [saddr4 | saddr6,--- daddr4 | daddr6, dport [, sport, backup, if_idx]]--genCapCwnd :: MptcpToken- -> Word16 -- ^family id- -> MptcpPacket-genCapCwnd token familyId =- assert (hasFamily attrs) pkt- where- pkt = genMptcpRequest familyId MPTCP_CMD_SND_CLAMP_WINDOW True attrs- -- attrs = Map.empty- attrs = [- MptcpAttrToken token- , SubflowFamily eAF_INET- , LocalLocatorId 0- -- TODO check emote locator ?- , RemoteLocatorId 0- , SubflowInterface localhostIntfIdx- -- , SubflowInterface localhostIntfIdx- ]- -- putStrLn "while waiting for a real implementation"---- Use a Mvar here to-startMonitorConnection :: MptcpSocket -> MVar MptcpConnection -> IO ()-startMonitorConnection mptcpSock mConn = do- -- ++ show token+{- |+ 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+ -> MptcpSocket+ -> NetlinkSocket+ -> MVar MptcpConnection -> IO ()+startMonitorConnection tmpdir mptcpSock sockMetrics mConn = do let (MptcpSocket sock familyId) = mptcpSock- putStr "Start monitoring connection..."+ myId <- myThreadId+ putStr $ show myId ++ "Start monitoring connection..." -- as long as conn is not empty we keep going ? -- for this connection -- query metrics for the whole MPTCP connection con <- readMVar mConn+ putStrLn "Showing MPTCP connection" putStrLn $ show con ++ "..." let token = connectionToken con -- let resetAttrs = [ (MptcpAttrToken token ), (LocalLocatorId 0)]- let masterSf = head $ subflows con- let newSubflowAttrs = [- MptcpAttrToken token- ] ++ (subflowAttrs $ masterSf { srcPort = 0 })- let capSubflowAttrs = [- MptcpAttrToken token- , SubflowMaxCwnd 3- , SubflowSourcePort $ srcPort masterSf- ] ++ (subflowAttrs masterSf)- let resetPkt = resetConnectionPkt mptcpSock resetAttrs- let newSfPkt = newSubflowPkt mptcpSock newSubflowAttrs- -- let capCwndPkt = capCwndPkt mptcpSock capSubflowAttrs-- -- updateCwndCap- -- queryOne- -- putStrLn $ "Sending RESET for token " ++ show token- -- query sock resetPkt >>= inspectAnswers-- -- putStrLn $ "Master sf " ++ show masterSf- -- putStrLn $ "Trying to cap subflow cwd... with token " ++ show token- -- putStrLn $ "Sending " ++ show capCwndPkt+ -- TODO this is the issue+ -- not sure it's the master with a set+ let masterSf = Set.elemAt 0 (subflows con) - -- putStrLn $ "Master sf " ++ show masterSf- -- putStrLn $ "Trying to create new subflow... with token " ++ show token- -- putStrLn $ "Sending " ++ show newSfPkt- -- query sock newSfPkt >>= inspectAnswers+ -- Get updated metrics+ lastMetrics <- mapM (updateSubflowMetrics sockMetrics) (Set.toList $ subflows con) putStrLn "Running mptcpnumerics"- cwnds <- getCapsForConnection con - putStrLn $ "Requesting to set cwnds..." ++ show cwnds- -- TODO capCwndAttrs capCwndPkt - -- KISS for now (capCwndPkt mptcpSock )- -- zip caps (subflows con) - let attrsList = map (\(cwnd, sf) -> capCwndAttrs token sf cwnd ) (zip cwnds (subflows con))- -- >> map (capCwndPkt mptcpSock ) >>= putStrLn "toto"+ -- 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 - -- query sock capCwndPkt >>= inspectAnswers- -- de type [MptcpPacket]- let cwndPackets = map (capCwndPkt mptcpSock) attrsList- mapM_ (query sock) cwndPackets >> putStrLn "test"- -- >>= inspectAnswers+ 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)) - -- then we should send a request for each cwnd- mapM_ updateSubflowMetrics (subflows con)+ mapM_ (sendPacket sock) cwndPackets - sleepMs monitoringRateMs+ sleepMs onSuccessSleepingDelay putStrLn "Finished monitoring token "+ -- call ourself again- startMonitorConnection mptcpSock mConn+ startMonitorConnection tmpdir mptcpSock sockMetrics mConn --- | This should return a list of cwnd to respect a certain scenario--- invoke--- 1. save the connection to a JSON file and pass it to mptcpnumerics--- 2.--- 3.--- Maybe ?-getCapsForConnection :: MptcpConnection -> IO [Word32]-getCapsForConnection con = do+++{-+ | This should return a list of cwnd to respect a certain scenario+ 1. save the connection to a JSON file and pass it to mptcpnumerics++-}+getCapsForConnection :: FilePath+ -> MptcpConnection+ -> [SockDiagMetrics]+ -> IO (Maybe [Word32])+getCapsForConnection tmpdir mptcpConn metrics = do -- returns a bytestring- let bs = Data.Aeson.encode con- let subflowCount = length $ subflows con- let filename = "mptcp_" ++ (show $ subflowCount) ++ "_" ++ (show $ connectionToken con) ++ ".json"- -- encode token in filename- -- fromMaybe $- Data.ByteString.Lazy.writeFile filename bs+ -- let (MptcpConnectionWithMetrics mptcpConn metrics) = conWithMetrics+ let jsonConn = (toJSON mptcpConn)+ let merged = lodashMerge jsonConn (object [ "subflows" .= metrics ])+ -- (toJSON jsonConn) ++ (toJSON metrics) - -- eitherDecode- -- TODO run readProcessWithExitCode instead- -- FilePath -> [String] -> String -> IO (ExitCode, String, String)+ -- 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+ -- TODO to keep it simple it should return a list of CWNDs to apply -- readProcessWithExitCode binary / args / stdin- (exitCode, stdout, stderr) <- readProcessWithExitCode "./fake_solver" [filename, show subflowCount] ""- case exitCode of+ (exitCode, stdout, stderrContent) <- readProcessWithExitCode (get_caps_prog mptcpConn) [filename, show subflowCount] ""++ putStrLn $ "exitCode: " ++ show exitCode+ putStrLn $ "stdout:\n" ++ stdout+ -- http://hackage.haskell.org/package/base/docs/Text-Read.html+ let values = (case exitCode of -- for now simple, we might read json afterwards- ExitSuccess -> return (read stdout :: [Word32])- ExitFailure val -> error $ "stdout:" ++ stdout ++ " stderr: " ++ stderr+ ExitSuccess -> (readMaybe stdout) :: Maybe [Word32]+ ExitFailure val -> error $ "stdout:" ++ stdout ++ " stderr: " ++ stderrContent+ )+ return values -- type Attributes = Map Int ByteString -- the library contains showAttrs / showNLAttrs@@ -454,6 +548,7 @@ show (GenlHeaderMptcp (GenlHeader cmd ver)) = "Header: Cmd = " ++ show cmd ++ ", Version: " ++ show ver ++ "\n" +-- inspectAnswers :: [GenlPacket NoData] -> IO () inspectAnswers packets = do mapM_ inspectAnswer packets@@ -465,12 +560,9 @@ -- in showPacket pkt showHeaderCustom :: GenlHeader -> String-showHeaderCustom hdr = show hdr+showHeaderCustom = show inspectAnswer :: GenlPacket NoData -> IO ()--- inspectAnswer packet = putStrLn $ "Inspecting answer:\n" ++ showPacket packet--- (GenlData NoData)--- inspectAnswer (Packet hdr (GenlData ghdr NoData) attributes) = putStrLn $ "Inspecting answer:\n" inspectAnswer (Packet _ (GenlData hdr NoData) attributes) = let cmd = genlCmd hdr in@@ -481,6 +573,7 @@ +-- should have this running in parallel queryAddrs :: NLR.RoutePacket queryAddrs = NL.Packet (NL.Header NLC.eRTM_GETADDR (NLC.fNLM_F_ROOT .|. NLC.fNLM_F_MATCH .|. NLC.fNLM_F_REQUEST) 0 0)@@ -488,103 +581,60 @@ mempty -handleMessage :: NLR.Message -> IO()-handleMessage (NLR.NLinkMsg _ _ _ ) = putStrLn $ "Ignoring NLinkMsg"-handleMessage (NLR.NNeighMsg _ _ _ _ _ ) = putStrLn $ "Ignoring NNeighMsg"-handleMessage (NLR.NAddrMsg _ _ _ _ _ ) = putStrLn $ "Ignoring NNeighMsg"---- TODO handle remove/new event-handleAddr :: Either String NLR.RoutePacket -> IO ()-handleAddr (Left errStr) = putStrLn $ "Error decoding packet: " ++ errStr-handleAddr (Right (Packet hdr pkt _)) = handleMessage pkt-handleAddr (Right (DoneMsg hdr)) = putStrLn $ "Error decoding packet: " ++ show hdr-handleAddr (Right (ErrorMsg hdr errorInt errorBstr )) = putStrLn $ "Error decoding packet: " ++ show hdr-+-- |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 ? ---onNewConnection :: MptcpSocket -> Attributes -> IO ()-onNewConnection sock attributes = do- -- TODO use getAttribute instead - let token = readToken $ Map.lookup (fromEnum MPTCP_ATTR_TOKEN) attributes- let locId = readLocId $ Map.lookup (fromEnum MPTCP_ATTR_LOC_ID) attributes- let answer = "e"- -- answer <- Prelude.getLine- -- putStrLn "What do you want to do ? (c.reate subflow, d.elete connection, r.eset connection)"- -- announceSubflow sock token >>= inspectAnswers >> putStrLn "Finished announcing"- case answer of- "c" -> do- putStrLn "Creating new subflow !!"- -- let pkt = createNewSubflow sock token attributes- return ()- "d" -> putStrLn "Not implemented"- -- removeSubflow sock token locId >>= inspectAnswers >> putStrLn "Finished announcing"- -- "e" -> putStrLn "check for existence" >>- -- checkIfSocketExists sock token >>= inspectAnswers- "r" -> putStrLn "Reset the connection" >>- -- TODO expects token- -- TODO discard result- -- resetTheConnection sock token >>= inspectAnswers >>- putStrLn "Finished resetting"- _ -> onNewConnection sock attributes- return ()-+-- availablePaths <- readMVar globalInterfaces+-- TODO put globalInterfaces in MyState ?+ -- let (MptcpSocket mptcpSockRaw fid) = mptcpSock+ -- let pkts = (onMasterEstablishement pathManager) mptcpSock mptcpConn availablePaths --- |Class to implement different path managers--- class PathManager a where--- onNewSubflow :: TcpConnection -> [MptcpPacket]+ -- putStrLn "List of requests made on new master:"+ -- mapM_ (sendPacket $ mptcpSockRaw) pkts --- unknownConnectionEvent :: M--- unknownConnectionMonitor :: MptcpToken -> MptcpPacket--- pass [MptcpAttribute] instead ?--- -dispatchPacketForKnownConnection :: MptcpConnection+-- TODO maybe the path manager should be part of the MptcpConnection+dispatchPacketForKnownConnection :: MptcpSocket+ -> MptcpConnection -> MptcpGenlEvent -> Attributes- -> MptcpConnection- -- -> IO MyState-dispatchPacketForKnownConnection con event attributes = let+ -> AvailablePaths+ -- -> Map.Map MptcpAttr MptcpAttribute+ -- -> MptcpConnection+ -> (Maybe MptcpConnection, [MptcpPacket])+dispatchPacketForKnownConnection mptcpSock con event attributes availablePaths = let token = connectionToken con+ subflow = subflowFromAttributes attributes in case event of- -- TODO wait for established instead ?- -- MPTCP_EVENT_CREATED -> do - MPTCP_EVENT_ESTABLISHED -> con- -- do- -- putStrLn "Connection established !"- -- TODO llok- -- return oldState+ -- let the Path manager kick in+ MPTCP_EVENT_ESTABLISHED -> let+ -- onMasterEstablishement mptcpSock + -- Needs IO because of NetworkInterface+ newPkts = (onMasterEstablishement pathManager) mptcpSock con availablePaths+ in+ (Just con, newPkts) - MPTCP_EVENT_ANNOUNCED -> con- -- putStrLn "New address announced"- -- case maybeConn of- -- Nothing -> putStrLn "No connection with this token" >> return oldState- -- Just mConn -> _- -- case mmakeAttributeFromMaybe MPTCP_ATTR_REM_ID attrs of - -- Nothing -> return oldState- -- Just localId ->- -- putStrLn "Found a match"- -- -- swapMVar / withMVar / modifyMVar- -- mptcpConn <- takeMVar mConn- -- -- TODO we should trigger an update in the CWND- -- let newCon = mptcpConnAddLocalId mptcpConn - -- let newState = oldState- -- return oldState+ -- TODO trigger the pathManager again, fix the remote interpretation+ MPTCP_EVENT_ANNOUNCED -> let+ -- what if it's local+ remId = remoteIdFromAttributes attributes+ -- TODO + -- newConn = mptcpConnAddRemoteId con remId+ newConn = con+ in+ (Just newConn, []) - MPTCP_EVENT_CLOSED -> do- -- putStrLn $ "Connection closed, deleting token " ++ show token- -- let newState = oldState { connections = Map.delete token (connections oldState) }- -- TODO we should kill the thread with killThread or empty the mVar !!- -- let newState = oldState- -- putStrLn $ "New state"- -- return newState- con+ MPTCP_EVENT_CLOSED -> (Nothing, []) - MPTCP_EVENT_SUB_ESTABLISHED -> let- subflow = subflowFromAttributes attributes- newCon = mptcpConnAddSubflow con subflow+ MPTCP_EVENT_SUB_ESTABLISHED -> let+ newCon = mptcpConnAddSubflow con subflow in- newCon+ (Just newCon,[]) -- let newState = oldState -- putMVar con newCon -- let newState = oldState { connections = Map.insert token newCon (connections oldState) }@@ -593,95 +643,186 @@ -- return newState -- TODO remove- MPTCP_EVENT_SUB_CLOSED -> con- -- putStrLn "Subflow closed"- -- putStrLn "TODO remove subflow"- -- >> mptcpConnRemoveSubflow- -- return oldState+ MPTCP_EVENT_SUB_CLOSED -> let+ newCon = mptcpConnRemoveSubflow con subflow+ in+ (Just newCon, []) - MPTCP_CMD_EXIST -> con+ -- MPTCP_CMD_EXIST -> con+ _ -> error $ "should not happen " ++ show event- -- >> return oldState --- TODO pass a PathManager--- |^++acceptConnection :: TcpConnection -> Bool+-- acceptConnection subflow = subflow `notElem` filteredConnections+acceptConnection subflow = True++-- |+mapSubflowToInterfaceIdx :: IP -> IO (Maybe Word32)+mapSubflowToInterfaceIdx ip = do++ res <- tryReadMVar globalInterfaces+ case res of+ Nothing -> error "Couldn't access the list of interfaces"+ Just interfaces -> return $ mapIPtoInterfaceIdx interfaces ip++++-- 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++ newConn <- newMVar newMptcpConn+ putStrLn $ "Connection established !!\n"++ -- create a new+ sockMetrics <- makeMetricsSocket+ -- start monitoring connection+ threadId <- forkOS (startMonitorConnection (out cliArgs) mptcpSock sockMetrics newConn)++ putStrLn $ "Inserting new MVar "+ let newState = oldState {+ connections = Map.insert token (threadId, newConn) (connections oldState)+ }+ return newState)++-- |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 ? token = readToken $ Map.lookup (fromEnum MPTCP_ATTR_TOKEN) attributes maybeMatch = Map.lookup token (connections oldState)- in+ in do+ putStrLn $ "Fetching available paths"+ availablePaths <- readMVar globalInterfaces++ putStrLn $ "dispatch cmd " ++ show cmd ++ " for token " ++ show token+ case maybeMatch of -- Unknown token- Nothing -> case cmd of- MPTCP_EVENT_CREATED -> do- putStrLn "Ignoring Creating EVENT"- return oldState+ Nothing -> do - MPTCP_EVENT_ESTABLISHED -> let subflow = subflowFromAttributes attributes+ putStrLn $ "Unknown token/connection " ++ show token+ case cmd of++ MPTCP_EVENT_ESTABLISHED -> do+ putStrLn "Ignoring Creating EVENT"+ -- let newMptcpConn = (MptcpConnection token [] Set.empty Set.empty)+ return oldState++ MPTCP_EVENT_CREATED -> let+ subflow = subflowFromAttributes attributes in- if subflow `notElem` filteredConnections- then do- putStrLn $ "filtered out connection" ++ show subflow - putStrLn $ "it was compared with " ++ show authorizedCon1 - return oldState- else (do- let newMptcpConn = MptcpConnection token [ subflow ] [] []- newConn <- newMVar newMptcpConn- putStrLn $ "Connection established !!\n" ++ showAttributes attributes- -- onNewConnection mptcpSock attributes- handle <- forkOS (startMonitorConnection mptcpSock newConn)- -- r <- createProces $ startMonitor token- -- putStrLn $ "Connection created !!\n" ++ show subflow- let newState = oldState { connections = Map.insert token (handle, newConn) (connections oldState) }- return newState)+ registerMptcpConnection oldState token subflow+ _ -> return oldState - _ -> return oldState+ Just (threadId, mvarConn) -> do+ putStrLn $ "MATT: Received request for a known connection "+ mptcpConn <- takeMVar mvarConn - Just (threadId, mvarConn) -> case cmd of+ putStrLn $ "Forwarding to dispatchPacketForKnownConnection "+ case dispatchPacketForKnownConnection mptcpSock mptcpConn cmd attributes availablePaths of+ (Nothing, _) -> do+ putStrLn $ "Killing thread " ++ show threadId+ killThread threadId+ return $ oldState { connections = Map.delete token (connections oldState) } - MPTCP_EVENT_CREATED -> error "We should not receive MPTCP_EVENT_CREATED from here !!!"- MPTCP_EVENT_SUB_CLOSED -> do- putStrLn $ "SUBFLOW WAS CLOSED"- return oldState+ (Just newConn, pkts) -> do+ putStrLn "putting mVar"+ putMVar mvarConn newConn+ -- TODO update state - MPTCP_EVENT_CLOSED -> do- putStrLn $ "Killing thread " ++ show threadId- killThread threadId- -- TODO remove - return $ oldState { connections = Map.delete token (connections oldState) }- -- let newState = oldState+ putStrLn "List of requests made on new master:"+ mapM_ (\pkt -> sendPacket mptcpSockRaw (trace ("TOTO" ++ show pkt) pkt)) pkts+ let newState = oldState {+ connections = Map.insert token (threadId, mvarConn) (connections oldState)+ }+ return newState - -- TODO update connection- -- TODO filter first- _ -> do- mptcpConn <- takeMVar mvarConn- let newConn = dispatchPacketForKnownConnection mptcpConn cmd attributes- putMVar mvarConn newConn- -- TODO update state- let newState = oldState { - connections = Map.insert token (threadId, mvarConn) (connections oldState) - }- return newState+ -- case cmd of + -- MPTCP_EVENT_CREATED -> error "We should not receive MPTCP_EVENT_CREATED from here !!!"+ -- MPTCP_EVENT_SUB_CLOSED -> do+ -- putStrLn $ "SUBFLOW WAS CLOSED"+ -- return oldState + -- MPTCP_EVENT_ANNOUNCED -> do+ -- -- what if it's local+ -- case makeAttributeFromMaybe MPTCP_ATTR_REM_ID attributes of+ -- Nothing -> con+ -- Just (RemoteLocatorId remId) -> do+ -- mptcpConnAddRemoteId con remId+ -- createNewSubflows mptcpSock mptcpConn+ -- _ -> error "Wrong translation"++ -- MPTCP_EVENT_CLOSED -> do+ -- putStrLn $ "Killing thread " ++ show threadId+ -- killThread threadId+ -- return $ oldState { connections = Map.delete token (connections oldState) }+ -- MPTCP_EVENT_ESTABLISHED -> do+ -- putStrLn "Connexion established"+ -- mptcpConn <- readMVar mvarConn+ -- createNewSubflows mptcpSock mptcpConn >> return oldState++ -- TODO update connection+ -- TODO filter first+ -- _ -> do++ -- putStrLn $ "Forwarding to dispatchPacketForKnownConnection "+ -- -- TODO convert attributes+ -- -- convertAttributesIntoMap + -- let newConn = dispatchPacketForKnownConnection mptcpSock mptcpConn cmd attributes+++ dispatchPacket s (DoneMsg err) = putStrLn "Done msg" >> return s -- EOK shouldn't be an ErrorMsg when it receives EOK ? dispatchPacket s (ErrorMsg hdr errCode errPacket) = do- putStrLn $ "Error msg of type " ++ showErrCode errCode ++ " Packet content:\n" ++ show errPacket+ if errCode == 0 then+ putStrLn $ "Received acknowledgement for " ++ show hdr+ else+ putStrLn $ "Error msg of type " ++ showErrCode errCode ++ " Packet content:\n" ++ show errPacket+ return s -- ++ show errPacket showError :: Show a => Packet a -> IO ()-showError (ErrorMsg hdr errCode errPacket) = do- putStrLn $ "Error msg of type " ++ showErrCode errCode ++ " Packet content:\n" +showError (ErrorMsg hdr errCode errPacket) =+ putStrLn $ "Error msg of type " ++ showErrCode errCode ++ " Packet content:\n" showError _ = error "Not the good overload" -- netlink must contain sthg for it@@ -697,11 +838,13 @@ -- ePERM -> "EPERM" -- eNOTCONN -> "NOT connected" -inspectResult :: MyState -> Either String MptcpPacket -> IO()-inspectResult myState result = case result of- Left ex -> putStrLn $ "An error in parsing happened" ++ show ex- Right myPack -> dispatchPacket myState myPack >> putStrLn "Valid packet"+inspectResult :: MyState -> Either String MptcpPacket -> IO MyState+inspectResult myState result = case result of+ Left ex -> putStrLn ("An error in parsing happened" ++ show ex) >> return myState+ Right myPack -> dispatchPacket myState myPack ++-- |Infinite loop basically doDumpLoop :: MyState -> IO MyState doDumpLoop myState = do let (MptcpSocket simpleSock fid) = socket myState@@ -709,24 +852,24 @@ results <- recvOne' simpleSock :: IO [Either String MptcpPacket] -- TODO retrieve packets- mapM_ (inspectResult myState) results+ -- 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 - newState <- doDumpLoop myState- return newState+ doDumpLoop modifiedState -- regarder dans query/joinMulticastGroup/recvOne-listenToEvents :: MptcpSocket -> CtrlAttrMcastGroup -> IO ()-listenToEvents (MptcpSocket sock fid) my_group = do+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- let globalState = MyState mptcpSocket Map.empty- _ <- doDumpLoop globalState- putStrLn "TOTO"+ _ <- doDumpLoop state+ putStrLn "end of listenToEvents" where- mptcpSocket = MptcpSocket sock fid- -- globalState = MyState mptcpSocket Map.empty+ (MptcpSocket sock fid) = socket state -- testing@@ -760,32 +903,32 @@ -dumpExtensionAttribute :: Int -> ByteString -> String+dumpExtensionAttribute :: Int -> ByteString -> SockDiagExtension dumpExtensionAttribute attrId value = let- eExtId = (toEnum attrId :: IDiagExt)+ eExtId = (toEnum attrId :: SockDiagExtensionId) ext_m = loadExtension attrId value in case ext_m of- Nothing -> "Could not load " ++ show eExtId ++ " \n"- Just ext -> traceId (show eExtId) ++ " " ++ showExtension ext ++ " \n"- -- show $ (toEnum attrId :: IDiagExt)+ Nothing -> error $ "Could not load " ++ show eExtId ++ " (unsupported)\n"+ Just ext -> ext+ -- traceId (show eExtId) ++ " " ++ showExtension ext ++ " \n" -showExtensionAttributes :: Attributes -> String-showExtensionAttributes attrs =+loadExtensionsFromAttributes :: Attributes -> [SockDiagExtension]+loadExtensionsFromAttributes attrs = let -- $ loadExtension- mapped = Map.foldrWithKey (\k v -> (dumpExtensionAttribute k v ++ )) "Dumping extensions:\n " attrs+ mapped = Map.foldrWithKey (\k v -> ([dumpExtensionAttribute k v] ++ )) [] attrs in mapped ----inspectIDiagAnswer :: Packet InetDiagMsg -> IO ()+{- Parses the requested informations+-}+inspectIDiagAnswer :: Packet SockDiagMsg -> Maybe SockDiagMetrics inspectIDiagAnswer (Packet hdr cus attrs) =- putStrLn ("Idiag custom " ++ show cus) >>- putStrLn ("Idiag header " ++ show hdr) >>- putStrLn (showExtensionAttributes attrs)-inspectIDiagAnswer p = putStrLn $ "test" ++ showPacket p+ Just $ SockDiagMetrics cus (loadExtensionsFromAttributes attrs)+ -- Just cus+inspectIDiagAnswer p = Nothing -- inspectIDiagAnswer (DoneMsg err) = putStrLn "DONE MSG" -- (GenlData NoData)@@ -797,59 +940,139 @@ -- ++ "Supposing it's a mptcp command: " ++ dumpCommand ( toEnum $ fromIntegral cmd) --- la en fait c des reponses que j'obtiens ?-inspectIdiagAnswers :: [Packet InetDiagMsg] -> IO ()-inspectIdiagAnswers packets = do- putStrLn "Start inspecting IDIAG answers"- mapM_ inspectIDiagAnswer packets- putStrLn "Finished inspecting answers"+-- |Convenience wrapper+data SockDiagMetrics = SockDiagMetrics {+ sockDiagMsg :: SockDiagMsg+ -- subflowSubflow :: TcpConnection+ , sockdiagMetrics :: [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+ 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++ -- 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+++ -- , "total_retrans" .= tcpi_total_retrans arg++ ]+ toJSON (TcpVegasInfo _ _ rtt minRtt) = object [ "rtt" .= toJSON (rtt :: Word32) ]+ toJSON (CongInfo cc) = object [ "cc" .= toJSON (cc) ]+ toJSON (DiagExtensionMemInfo wmem rmem _ _) = object [+ "wmem" .= toJSON ( wmem :: Word32 )+ , "rmem" .= toJSON ( rmem :: Word32 )+ ]+ toJSON _ = object []++-- TODO merge+--+instance ToJSON SockDiagMetrics where+ -- attributes of array+ -- foldr over array of extensions+ toJSON (SockDiagMetrics msg metrics) = let++ 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+ ]+ fn x y = lodashMerge (toJSON x) y++ in+ -- (a -> b -> b) -> b -> t a -> b+ foldr fn initialValue metrics+++-- |Updates the list of interfaces+-- should run in background+trackSystemInterfaces :: IO()+trackSystemInterfaces = do+ -- check routing information+ routingSock <- NLS.makeNLHandle (const $ pure ()) =<< NL.makeSocket+ let cb = NLS.NLCallback (pure ()) (handleAddr . runGet getGenPacket)+ NLS.nlPostMessage routingSock queryAddrs cb+ NLS.nlWaitCurrent routingSock+ dumpSystemInterfaces+++-- | Remove ?+inspectIdiagAnswers :: [Packet SockDiagMsg] -> [Maybe SockDiagMetrics]+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)++ infoM "main" "Parsing command line..." options <- execParser opts - -- crashes when threaded- -- logger <- createLogger- -- pushLogStr logger (toLogStr "ok")+ infoM "main" "Creating MPTCP netlink socket..." - -- globalState <- newIORef mempty- -- globalState <- newEmptyMVar- -- putStrLn "dumping important values:"- -- putStrLn $ "RESET" ++ show MPTCP_CMD_REMOVE- -- putStrLn $ dumpMptcpCommands MPTCP_CMD_UNSPEC- putStrLn "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 instead !- -- globalState <- newMVar $ MyState (MptcpSocket sock fid) Map.empty putMVar globalMptcpSock (MptcpSocket sock fid) - putStrLn "Creating metrics netlink socket..."- sockMetrics <- makeMetricsSocket- -- putMVar- putMVar globalMetricsSock sockMetrics--- -- - routingSock <- NLS.makeNLHandle (const $ pure ()) =<< NL.makeSocket- let cb = NLS.NLCallback (pure ()) (handleAddr . runGet getGenPacket)- NLS.nlPostMessage routingSock queryAddrs cb- NLS.nlWaitCurrent routingSock+ infoM "main" "Now Tracking system interfaces..."+ putMVar globalInterfaces Map.empty+ routeNl <- forkIO trackSystemInterfaces - putStr "socket created. MPTCP Family id " >> Prelude.print fid+ 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- -- mcastMetricGroups <- getMulticastGroups sockMetrics fidMetrics mcastMptcpGroups <- getMulticastGroups sock fid mapM_ Prelude.print mcastMptcpGroups - -- mapM_ (listenToMetricEvents sockMetrics) mcastMetricGroups- mapM_ (listenToEvents (MptcpSocket sock fid)) mcastMptcpGroups+ let mptcpSocket = (MptcpSocket sock fid)+ let globalState = MyState mptcpSocket Map.empty options++ mapM_ (listenToEvents globalState) mcastMptcpGroups -- putStrLn $ " Groups: " ++ unwords ( map grpName mcastMptcpGroups ) putStrLn "finished"
− hs/monitor.hs
@@ -1,68 +0,0 @@-import Options.Applicative hiding (value, ErrorMsg)-import qualified Options.Applicative (value)-import qualified System.Environment as Env-import System.Log.FastLogger ()-import Data.Word (Word8, Word16, Word32)-import Net.Mptcp-import System.Linux.Netlink hiding (makeSocket)----- instance Show TcpConnection where--- show (TcpConnection srcIp dstIP srcPort dstPort) = "Src IP: " ++ srcIp-data MetricsSocket = MetricsSocket NetlinkSocket Word16----data Sample = Sample- { command :: String- , quiet :: Bool- , enthusiasm :: Int }----- TODO register subcommands instead-sample :: Parser Sample-sample = Sample- <$> argument str- ( metavar "CMD"- <> help "What to do" )- <*> switch- ( long "verbose"- <> short 'v'- <> help "Whether to be quiet" )- <*> option auto- ( long "enthusiasm"- <> help "How enthusiastically to greet"- <> showDefault- <> Options.Applicative.value 1- <> metavar "INT" )---opts :: ParserInfo Sample-opts = info (sample <**> helper)- ( fullDesc- <> progDesc "Print a greeting for TARGET"- <> header "hello - a test for optparse-applicative" )---main :: IO ()-main = do- -- let token = - case Env.getEnv "token" of- Nothing -> error "Needs the token of the connection to monitor"- Just token -> putStrLn "Monitoring token " ++ show token- putStrLn $ "Starting monitoring connection with token " ++ show token- (MptcpSocket sock fid) <- makeMptcpSocket- putStr "socket created. MPTCP Family id " >> print fid- let mptcpConnection = MptcpConnection token []-- -- (sockMetrics, fidMetrics) <- makeMetricsSocket- putStrLn "Creating metrics netlink socket..."- sockMetrics <- makeMetricsSocket-- mapM_ (listenToEvents (MptcpSocket sock fid)) mcastMptcpGroups-- -- sendPacket- sendPacket sockMetrics genQueryPacket >> putStrLn "Sent the TCP SS request"-- -- exported from my own version !!- recvMulti sockMetrics >>= inspectIdiagAnswers
− hs/test.hs
@@ -1,65 +0,0 @@-import Prelude hiding (length, concat)--- import Options.Applicative hiding (value)--- import qualified Options.Applicative (value)--import Generated-import Data.Bits ()-import Data.Bits (( .|.))--- import System.Linux.Netlink hiding (makeSocket)--- import System.Linux.Netlink (query, bufferSize)--- import System.Linux.Netlink.GeNetlink--- import System.Linux.Netlink.Constants---- import System.Linux.Netlink.GeNetlink.Control as C--- import Data.Word (Word8, Word16, Word32)--- import Data.List (intercalate)--- import Data.Serialize.Put--import IDiag---- import Data.ByteString as BS hiding (putStrLn, putStr, map, intercalate)--- import qualified Data.ByteString.Lazy as BSL---- import Debug.Trace--- import Control.Exception---- data MptcpSocket = MptcpSocket NetlinkSocket Word16---- mptcpGenlEvGrpName :: String--- mptcpGenlEvGrpName = "mptcp_events"--- mptcpGenlCmdGrpName :: String--- mptcpGenlCmdGrpName = "mptcp_commands"--- mptcpGenlName :: String--- mptcpGenlName="mptcp"---- makeMptcpSocket :: IO MptcpSocket--- makeMptcpSocket = do--- sock <- makeSocket--- putStrLn "socket created"--- res <- getFamilyIdS sock mptcpGenlName--- case res of--- Nothing -> error $ "Could not find family " ++ mptcpGenlName--- Just fid -> return (MptcpSocket sock (trace ("family id"++ show fid ) fid))----- instance Bits TcpState where--- shiftL x = shiftL (fromEnum x - 1)----- in fact it's 1 << fromEnum TcpListen)--- (fromEnum TcpListen) .|. (fromEnum TcpEstablished)---- #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))--main :: IO ()-main = let - -- TODO test with shiftL- toto = (fromEnum TcpListen) .|. (fromEnum TcpEstablished)- in do- putStrLn $ "InetDiag =" ++ show (fromEnum InetDiagMeminfo)- putStrLn $ "TcpListen =" ++ show (enumsToWord [TcpListen])- putStrLn $ "TcpEstablished =" ++ show (enumsToWord [TcpEstablished])- putStrLn $ "combo !!" ++ show (enumsToWord [TcpEstablished, TcpListen])- putStrLn "finished"
mptcp-pm.cabal view
@@ -1,6 +1,6 @@ cabal-version: 2.2 name: mptcp-pm-version: 0.0.1+version: 0.0.2 license: GPL-3.0-only license-file: LICENSE build-type: Simple@@ -26,89 +26,87 @@ } --- TODO write a rule specific to generated files--- , ip requires hspec_2_7 -- iproute/network-info bad--- bitset, fails+-- bitset, very interesting but broken -- aeson to (de)serialize to json -- brittany for formatting (does not work) -- use containers for Data.Set ?--- bytestring-conversion,+-- 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, aeson,- netlink >= 1.1.1.0, bytestring-conversion, c2hsc+ 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- ghc-options: -Wall -fno-warn-unused-binds -fno-warn-unused-matches+ -- -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 if flag(Dev) build-depends: netlink>= 1.1.1.1 -- for the generated.hsc , c2hs seems good to generate headers Build-tools: hsc2hs, c2hs -- apparently this just helps getting a better error messages- Includes: tcp_states.h, linux/sock_diag.h, linux/inet_diag.h- Other-modules: Net.SockDiag, Net.Tcp, Net.Mptcp, Net.IPAddress, Generated+ 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- -- , Net.TcpInfo- autogen-modules: Generated+ include-dirs: headers+ autogen-modules: Net.Mptcp.Constants, Net.SockDiag.Constants, Net.Tcp.Constants -- monitor new mptcp connections -- and delegate the behavior to a monitor-executable daemon- import: shared-properties- -- build-depends: MyCustomLibrary- -- ghc-options: -i/home/teto/netlink-hs- ghc-options: -Wall -fno-warn-unused-binds -fno-warn-unused-matches -threaded- main-is: daemon.hs- -- extra-packages: netlink- -- extra-lib-dirs: /home/teto/netlink-hs- hs-source-dirs: ., hs---- will monitor a specific mptcp connection-executable monitor- import: shared-properties- main-is: hs/monitor.hs---- for short tests-executable short+executable mptcp-pm import: shared-properties- main-is: hs/test.hs+ -- 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- -- autogen-modules: Generated+-- 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 -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: Generated, Net.SockDiag, Net.Mptcp, Net.IPAddress- autogen-modules: Generated- include-dirs: headers- build-depends: base >=4.12 && <4.20- , HUnit- , netlink- , cereal- , ip- , bytestring- , containers- , aeson- -- , test-framework- -- , test-framework-hunit+-- 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/Main.hs
@@ -1,86 +0,0 @@-{-| -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 Generated-import IDiag-import Net.Mptcp-import Net.IP-import Net.IPv4 (localhost)---- main = do--- putStrLn "This test always fails!"--- exitFailure--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- , inetFamily = 2- }--modifiedConnection = iperfConnection {- subflowInterface = Just 0-}--filteredConnections :: [TcpConnection]-filteredConnections = [- iperfConnection- ]---connectionFilter = TestCase $ assertBool- "Check connection is in the list"- (iperfConnection `elem` filteredConnections)---- connectionFilter = TestCase $ assertEqual--- "Check connection is in the list"--- True--- ( iperfConnection `elem` filteredConnections)---- main :: IO Count-main = do-- results <- runTestTT $ TestList [- -- testEmpty- -- , testCombo- -- , testComboReverse,- TestLabel "subflow is correctly filtered" connectionFilter- , TestCase $ assertBool "connection should be equal" (iperfConnection == iperfConnection)- , TestCase $ assertBool "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)- ]- if (errors results + failures results == 0)- then- exitWith ExitSuccess- else- exitWith (ExitFailure 1)