mptcp-pm 0.0.3 → 0.0.4
raw patch · 24 files changed
+2729/−2431 lines, 24 filesdep +formattingdep +polysemydep +polysemy-logdep −hsloggerdep −katipdep ~basedep ~ipdep ~netlink
Dependencies added: formatting, polysemy, polysemy-log, polysemy-log-co, polysemy-plugin, readable
Dependencies removed: hslogger, katip
Dependency ranges changed: base, ip, netlink
Files
- Net/Bitset.hs +0/−27
- Net/IPAddress.hs +0/−68
- Net/Mptcp.hs +0/−471
- Net/Mptcp/PathManager.hs +0/−202
- Net/Mptcp/PathManager/Default.hs +0/−71
- Net/SockDiag.hs +0/−541
- Net/Tcp.hs +0/−20
- Net/Tcp/Definitions.hs +0/−76
- README.md +5/−1
- hs/daemon.hs +0/−880
- mptcp-pm.cabal +119/−66
- src/Net/Bitset.hs +27/−0
- src/Net/IPAddress.hs +79/−0
- src/Net/Mptcp.hs +486/−0
- src/Net/Mptcp/Constants.chs +50/−0
- src/Net/Mptcp/PathManager.hs +207/−0
- src/Net/Mptcp/PathManager/Default.hs +79/−0
- src/Net/SockDiag.hs +524/−0
- src/Net/SockDiag/Constants.chs +37/−0
- src/Net/Tcp.hs +20/−0
- src/Net/Tcp/Constants.chs +86/−0
- src/Net/Tcp/Definitions.hs +84/−0
- src/app/Main.hs +918/−0
- test/Main.hs +8/−8
− Net/Bitset.hs
@@ -1,27 +0,0 @@-{-# LANGUAGE DefaultSignatures #-}-module Net.Bitset-where-import Data.Bits-import Control.Monad--class ToBitMask a where- toBitMask :: a -> Int- -- | Using a DefaultSignatures extension to declare a default signature with- -- an `Enum` constraint without affecting the constraints of the class itself.- default toBitMask :: Enum a => a -> Int- toBitMask = shiftL 1 . fromEnum--instance ( ToBitMask a ) => ToBitMask [a] where- toBitMask = foldr (.|.) 0 . map toBitMask---- | Not making this a typeclass, since it already generalizes over all--- imaginable instances with help of `MonadPlus`.-fromBitMask ::- ( MonadPlus m, Enum a, Bounded a, ToBitMask a ) =>- Int -> m a-fromBitMask bm = msum $ map asInBM $ enumFrom minBound- where- asInBM a = if isInBitMask bm a then return a else mzero--isInBitMask :: ( ToBitMask a ) => Int -> a -> Bool-isInBitMask bm a = let aBM = toBitMask a in aBM == aBM .&. bm
− Net/IPAddress.hs
@@ -1,68 +0,0 @@--- |--- Description----{-# OPTIONS_GHC -fno-warn-orphans #-}-module Net.IPAddress-where-import Net.IP-import Net.IPv4-import Net.IPv6-import Data.Serialize.Get-import Data.Serialize.Put-import Data.ByteString-import System.Linux.Netlink.Constants as NLC--import Control.Monad---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 =- let- val = Net.IPv6.fromWord32s <$> getWord32be <*> getWord32be <*> getWord32be <*> getWord32be- in- runGet val bs---putIPAddress :: IP -> Put-putIPAddress addr =- case_ putIPv4Address putIPv6Address addr---- the doc should show the MSB-putIPv6Address :: IPv6 -> Put-putIPv6Address addr =- let- (w1, w2, w3, w4) = toWord32s addr- in do- putWord32be w1- putWord32be w2- putWord32be w3- putWord32be w4---- |IDIag version since it will add some padding to reach 128 bits-putIPv4Address :: IPv4 -> Put-putIPv4Address addr =- let- w32 = getIPv4 addr- in do- putWord32be w32- 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
@@ -1,471 +0,0 @@-{-|-Module : MPTCP-Description : Implementation of mptcp netlink path manager-Maintainer : matt-Stability : testing-Portability : Linux--OverloadedStrings allows Aeson to convert--}-{-# LANGUAGE DeriveGeneric #-}-{-# LANGUAGE OverloadedStrings #-}-module Net.Mptcp-where--import Net.SockDiag ()-import Control.Exception (assert)--import Data.Word (Word8, Word16, Word32)-import qualified Data.Map as Map-import System.Linux.Netlink hiding (makeSocket)--- import System.Linux.Netlink (query, Packet(..))-import System.Linux.Netlink.GeNetlink-import System.Linux.Netlink.Constants--- import System.Linux.Netlink.GeNetlink.Control-import Data.ByteString (ByteString)-import Data.Maybe (fromJust)--import Data.Serialize.Get-import Data.Serialize.Put--import Data.Bits ((.|.))--import Data.List ()-import Debug.Trace-import Control.Concurrent ()-import Net.IP-import Net.Tcp-import Net.IPAddress-import Net.IPv4-import Net.IPv6-import Net.Mptcp.Constants-import qualified Data.Set as Set-import Data.Aeson-import GHC.Generics-import Control.Monad.Trans.State ()--data MptcpSocket = MptcpSocket NetlinkSocket Word16-instance Show MptcpSocket where- show sock = let (MptcpSocket _ fid) = sock in ("Mptcp netlink socket: " ++ show fid)--type MptcpPacket = GenlPacket NoData---- |Same as SockDiagMetrics--- data SubflowWithMetrics = SubflowWithMetrics {--- subflowSubflow :: TcpConnection--- -- for now let's retain DiagTcpInfo only--- , metrics :: [SockDiagExtension]--- }---- |Holds MPTCP level information-data MptcpConnection = MptcpConnection {- connectionToken :: MptcpToken- -- use SubflowWithMetrics instead ?!- -- , subflows :: Set.Set [TcpConnection]- , subflows :: Set.Set TcpConnection- , localIds :: Set.Set Word8 -- ^ Announced addresses- , remoteIds :: Set.Set Word8 -- ^ Announced addresses-- -- Might be reworked/moved in an Enriched/Tracker structure afterwards- , get_caps_prog :: Maybe FilePath-} deriving (Show, Generic)---- | Remote port-data RemoteId = RemoteId {-- remoteAddress :: IP- , remotePort :: Word16-}----remoteIdFromAttributes :: Attributes -> RemoteId-remoteIdFromAttributes attrs = let- (SubflowDestPort dport) = fromJust $ makeAttributeFromMaybe MPTCP_ATTR_DPORT attrs- -- (SubflowFamily _) = 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---- | 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 ([])- ]----- |Adds a subflow to the connection--- TODO compose with mptcpConnAddLocalId-mptcpConnAddSubflow :: MptcpConnection -> TcpConnection -> MptcpConnection-mptcpConnAddSubflow mptcpConn sf =- -- trace ("Adding subflow" ++ show sf)- mptcpConnAddLocalId- (mptcpConnAddRemoteId- (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- -> MptcpConnection-mptcpConnAddLocalId con locId = con { localIds = Set.insert (locId) (localIds con) }----- |Add remote id-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 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- Left _ -> 0- 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 _ 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 }---{-|- Generates an Mptcp netlink request-TODO we could fake the Word16/Flag and --}-genMptcpRequest :: Word16 -- ^the family id- -> MptcpGenlEvent -- ^The MPTCP command- -> Bool -- ^Dump answer (returns EOPNOTSUPP if not possible)- -- -> Attributes- -> [MptcpAttribute]- -> MptcpPacket-genMptcpRequest fid cmd dump attrs =- let- 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- word8Cmd = fromIntegral (fromEnum cmd) :: Word8-- pkt = Packet myHeader (GenlData geheader NoData) (mptcpListToAttributes attrs)- -- TODO run an assert on the list filter- hasTokenAttr = Prelude.any (isAttribute (MptcpAttrToken 0)) attrs- in- assert hasTokenAttr pkt--readToken :: Maybe ByteString -> MptcpToken-readToken maybeVal = case maybeVal of- Nothing -> error "Missing token"- Just val -> case ( runGet getWord32host val) of- Left err -> error "could not decode"- Right mptcpToken -> mptcpToken---- LocId => Word8-readLocId :: Maybe ByteString -> LocId-readLocId maybeVal = case maybeVal of- Nothing -> error "Missing locator id"- Just val -> case runGet getWord8 val of- -- TODO generate an error here !- Left _ -> error "Could not get locId !!"- Right locId -> locId- -- runGet getWord8 val---- doDumpLoop :: MyState -> IO MyState--- doDumpLoop myState = do--- let (MptcpSocket simpleSock fid) = socket myState--- results <- recvOne' simpleSock :: IO [Either String MptcpPacket]--- -- TODO retrieve packets--- mapM_ (inspectResult myState) results--- newState <- doDumpLoop myState--- 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)---- 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 | -- ^ should be Word16 too- -- remote/local ?- RemoteLocatorId Word8 |- LocalLocatorId Word8 |- SubflowSourceAddress IP |- SubflowDestAddress IP |- SubflowSourcePort Word16 |- SubflowDestPort Word16 |- SubflowMaxCwnd Word32 |- SubflowBackup Word8 |- SubflowInterface Word32- deriving (Show, Eq)--type MptcpToken = Word32-type LocId = Word8---- inspired by netlink cATA :: CtrlAttribute -> (Int, ByteString)-attrToPair :: MptcpAttribute -> (Int, ByteString)-attrToPair (MptcpAttrToken token) = (fromEnum MPTCP_ATTR_TOKEN, runPut $ putWord32host token)-attrToPair (RemoteLocatorId loc) = (fromEnum MPTCP_ATTR_REM_ID, runPut $ putWord8 loc)-attrToPair (LocalLocatorId loc) = (fromEnum MPTCP_ATTR_LOC_ID, runPut $ putWord8 loc)-attrToPair (SubflowFamily fam) = let- fam8 = (fromIntegral $ fromEnum fam) :: Word16- in (fromEnum MPTCP_ATTR_FAMILY, runPut $ putWord16host fam8)--attrToPair ( SubflowInterface idx) = (fromEnum MPTCP_ATTR_IF_IDX, runPut $ putWord32host idx)-attrToPair ( SubflowSourcePort port) = (fromEnum MPTCP_ATTR_SPORT, runPut $ putWord16host port)-attrToPair ( SubflowDestPort port) = (fromEnum MPTCP_ATTR_DPORT, runPut $ putWord16host port)-attrToPair ( SubflowMaxCwnd limit) = (fromEnum MPTCP_ATTR_CWND, runPut $ putWord32host limit)-attrToPair ( SubflowBackup prio) = (fromEnum MPTCP_ATTR_BACKUP, runPut $ putWord8 prio)--- TODO should depend on the ip putWord32be w32-attrToPair ( SubflowSourceAddress addr) =- case_ (genV4SubflowAddress MPTCP_ATTR_SADDR4) (genV6SubflowAddress MPTCP_ATTR_SADDR6) addr-attrToPair ( SubflowDestAddress addr) =- case_ (genV4SubflowAddress MPTCP_ATTR_DADDR4) (genV6SubflowAddress MPTCP_ATTR_DADDR6) addr---genV4SubflowAddress :: MptcpAttr -> IPv4 -> (Int, ByteString)-genV4SubflowAddress attr ip = (fromEnum attr, runPut $ putWord32be w32)- where- w32 = getIPv4 ip--genV6SubflowAddress :: MptcpAttr -> IPv6 -> (Int, ByteString)-genV6SubflowAddress _addr = undefined--mptcpListToAttributes :: [MptcpAttribute] -> Attributes-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 =- let- -- expects a ByteString- 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- -- TODO fix sfFamily- TcpConnection _srcIp _dstIp sport dport prio lid rid (Just intfId)----- TODO prefix with 'e' for enum--- Map.lookup (fromEnum attr) m--- getAttribute :: MptcpAttr -> Attributes -> Maybe MptcpAttribute--- getAttribute attr m--- | attr == MPTCP_ATTR_TOKEN = Nothing--- | otherwise = Nothing---- getAttribute :: (Int, ByteString) -> CtrlAttribute--- getAttribute (i, x) = fromMaybe (CTRL_ATTR_UNKNOWN i x) $makeAttribute i x---- getW16 :: ByteString -> Maybe Word16--- getW16 x = e2M (runGet g16 x)---- getW32 :: ByteString -> Maybe Word32--- getW32 x = e2M (runGet g32 x)---- "either2Maybe"-e2M :: Either a b -> Maybe b-e2M (Right x) = Just x-e2M _ = Nothing--convertAttributesIntoMap :: Attributes -> Map.Map MptcpAttr MptcpAttribute-convertAttributesIntoMap attrs = let- customFn k val = fromJust (makeAttribute k val)- 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 -> error $ "Could not build attr " ++ show attrType- Just bytestring -> makeAttribute (fromEnum attrType) bytestring---- | Builds an MptcpAttribute from-makeAttribute :: Int -- ^ MPTCP_ATTR_TOKEN value- -> ByteString- -> Maybe MptcpAttribute-makeAttribute i val =- case toEnum i of- MPTCP_ATTR_TOKEN -> Just (MptcpAttrToken $ readToken $ Just val)- -- 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)- MPTCP_ATTR_DADDR6 -> SubflowDestAddress <$> fromIPv6 <$> e2M (getIPv6FromByteString val)- MPTCP_ATTR_SPORT -> SubflowSourcePort <$> port where port = e2M $ runGet getWord16host val- 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 -> trace ("if_idx: " ++ show val) (- case runGet getWord32be val of- Right x -> Just $ SubflowInterface x- _ -> 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- MPTCP_ATTR_FLAGS -> trace "makeAttribute ATTR_FLAGS" Nothing- MPTCP_ATTR_UNSPEC -> undefined---dumpAttribute :: Int -> ByteString -> String-dumpAttribute attrId value =- show $ makeAttribute attrId value--checkIfSocketExistsPkt :: Word16 -> [MptcpAttribute] -> MptcpPacket-checkIfSocketExistsPkt fid attributes =- genMptcpRequest fid MPTCP_CMD_EXIST True attributes---- https://stackoverflow.com/questions/47861648/a-general-way-of-comparing-constructors-of-two-terms-in-haskell?noredirect=1&lq=1--- attrToPair ( SubflowSourcePort port) = (fromEnum MPTCP_ATTR_SPORT, runPut $ putWord8 loc)-isAttribute :: MptcpAttribute -- ^ to compare with- -> MptcpAttribute -- ^to compare to- -> 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--hasFamily :: [MptcpAttribute] -> Bool-hasFamily = Prelude.any (isAttribute (SubflowFamily eAF_INET))---- 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- in- assert (hasLocAddr attrs) $ genMptcpRequest fid MPTCP_CMD_REMOVE False attrs----- pass token ?-subflowAttrs :: TcpConnection -> [MptcpAttribute]-subflowAttrs con = [- LocalLocatorId $ localId con- , RemoteLocatorId $ remoteId con- , 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- ]---- |Generate a request to create a new subflow-capCwndPkt :: MptcpSocket -> MptcpConnection- -> Word32 -- ^Limit to apply to congestion window- -> TcpConnection -> MptcpPacket-capCwndPkt (MptcpSocket _ fid) mptcpCon limit sf =- assert (hasFamily attrs) pkt- where- oldPkt = genMptcpRequest fid MPTCP_CMD_SND_CLAMP_WINDOW False attrs- 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-newSubflowPkt :: MptcpSocket -> MptcpConnection -> TcpConnection -> MptcpPacket-newSubflowPkt (MptcpSocket _ fid) mptcpCon sf = let- _cmd = MPTCP_CMD_SUB_CREATE- attrs = connectionAttrs mptcpCon ++ subflowAttrs sf- pkt = genMptcpRequest fid MPTCP_CMD_SUB_CREATE False attrs- in- assert (hasFamily attrs) pkt-
− Net/Mptcp/PathManager.hs
@@ -1,202 +0,0 @@-{--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
@@ -1,71 +0,0 @@-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
@@ -1,541 +0,0 @@-{-|- ipSrc <- IPAddress . pack <$> replicateM (4*8) getWord8- -- ipSrc = IPAddress . pack <$> replicateM (4*8) getWord8- ipDst <- IPAddress . pack <$> replicateM (4*8) getWord8 -Module : IDiag-Description : Implementation of mptcp netlink path manager-Maintainer : matt-Stability : testing-Portability : Linux---}-{-# LANGUAGE FlexibleInstances #-}-{-# LANGUAGE DeriveGeneric #-}-{-# LANGUAGE DeriveAnyClass #-}-module Net.SockDiag (- SockDiagMsg (..)- , SockDiagExtension (..)- , genQueryPacket- , loadExtension- , showExtension- , connectionFromDiag- -- WARN dont use it will be removed- , enumsToWord-) where---- import Generated-import Data.Word (Word8, Word16, Word32, Word64)--import Prelude hiding (length, concat, init)--import Data.Maybe (fromJust)-import Data.Either (fromRight)--import Data.Serialize-import Data.Serialize.Get ()-import Data.Serialize.Put ()---- import Control.Monad (replicateM)--import System.Linux.Netlink-import System.Linux.Netlink.Constants--import qualified Data.Bits as B-import Data.Bits ((.|.))-import qualified Data.Map as Map-import Data.ByteString (ByteString, pack)-import Data.ByteString.Char8 as C8 (unpack, init)-import Net.IPAddress-import Net.IP ()--- import Net.IPv4-import Net.Tcp-import Net.SockDiag.Constants------- 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----- TODO provide constructor from Cookie--- and one fronConnection--- {| InetDiagFromCookie Word64------ |}-data InetDiagSockId = InetDiagSockId {- 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];- -- __be32 idiag_dst[4];- -- we don't know yet the address family- , idiag_src :: ByteString- , idiag_dst :: ByteString-- , idiag_intf :: Word32 -- ^Interface id- , idiag_cookie :: Word64 -- ^To specifically request an sockid--} deriving (Eq, Show)--{-# OPTIONS_GHC -Wno-incomplete-patterns #-}----- TODO we need a way to rebuild from the integer to the enum-class Enum2Bits a where- -- toBits :: [a] -> Word32- shiftL :: a -> Word32--instance Enum2Bits TcpState where- shiftL state = B.shiftL 1 (fromEnum state)--instance Enum2Bits SockDiagExtensionId where- shiftL state = B.shiftL 1 (fromEnum state - 1)----enumsToWord :: Enum2Bits a => [a] -> Word32-enumsToWord [] = 0-enumsToWord (x:xs) = (shiftL x) .|. (enumsToWord xs)---- TODO use bitset package ? but broken-wordToEnums :: Enum2Bits a => Word32 -> [a]-wordToEnums _ = []--{- | 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- , idiag_expires :: Word32- , idiag_rqueue :: Word32- , idiag_wqueue :: Word32- , idiag_uid :: Word32- , idiag_inode :: Word32-} deriving (Eq, Show)--{-# LANGUAGE FlexibleInstances #-}---- TODO this generates the error "Orphan instance: instance Convertable [TcpState]"--- instance Convertable [TcpState] where--- getPut = putStates--- getGet _ = return []--putStates :: [TcpState] -> Put-putStates states = putWord32host $ enumsToWord states---instance Convertable SockDiagMsg where- getPut = putSockDiagMsg- getGet _ = getSockDiagMsg---- TODO rename to a TCP one ? SockDiagRequest-data SockDiagRequest = SockDiagRequest {- sdiag_family :: Word8 -- ^AF_INET6 or AF_INET (TODO rename)--- 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- -- 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- , idiag_states :: [TcpState] -- ^States to dump (based on TcpDump) Word32- , diag_sockid :: InetDiagSockId -- ^inet_diag_sockid -} deriving (Eq, Show)--{- |Typeclase used by the system. Basically 'Storable' for 'Get' and 'Put'-getGet Returns a 'Get' function for the convertable.-The MessageType is passed so that the function can parse different data structures-based on the message type.--}--- class Convertable a where--- getGet :: MessageType -> Get a -- ^get a 'Get' function for the static data--- getPut :: a -> Put -- ^get a 'Put' function for the static data-instance Convertable SockDiagRequest where- getPut = putSockDiagRequestHeader- -- MessageType- getGet _ = getSockDiagRequestHeader---- |'Get' function for 'GenlHeader'--- applicative style Trade <$> getWord32le <*> getWord32le <*> getWord16le-getSockDiagRequestHeader :: Get SockDiagRequest-getSockDiagRequestHeader = do- addressFamily <- getWord8 -- AF_INET for instance- protocol <- getWord8- extended <- getWord32host- _pad <- getWord8- -- TODO discarded later- states <- getWord32host- _sockid <- getInetDiagSockid- -- TODO reestablish states- return $ SockDiagRequest addressFamily protocol- (wordToEnums extended :: [SockDiagExtensionId]) (wordToEnums states :: [TcpState]) _sockid---- |'Put' function for 'GenlHeader'-putSockDiagRequestHeader :: SockDiagRequest -> Put-putSockDiagRequestHeader request = do- -- let states = enumsToWord $ idiag_states request- putWord8 $ sdiag_family request- putWord8 $ sdiag_protocol request- -- extended todo use Enum2Bits- --putWord32host $ enumsToWord states- putWord8 ( fromIntegral (enumsToWord $ idiag_ext request) :: Word8)- putWord8 0 -- padding ?- -- TODO check endianness- 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 ?-getSockDiagMsg :: Get SockDiagMsg-getSockDiagMsg = do- family <- getWord8- state <- getWord8- timer <- getWord8- retrans <- getWord8-- _sockid <- getInetDiagSockid- expires <- getWord32host- rqueue <- getWord32host- wqueue <- getWord32host- uid <- getWord32host- inode <- getWord32host- return$ SockDiagMsg (fromIntegral family) state timer retrans _sockid expires rqueue wqueue uid inode--putSockDiagMsg :: SockDiagMsg -> Put-putSockDiagMsg msg = do- putWord8 $ fromIntegral $ fromEnum $ idiag_family msg- putWord8 $ idiag_state msg- putWord8 $ idiag_timer msg- putWord8 $ idiag_retrans msg-- putInetDiagSockid $ idiag_sockid msg-- -- Network order- putWord32le $ idiag_expires msg- putWord32le $ idiag_rqueue msg- putWord32le $ idiag_wqueue msg- putWord32le $ idiag_uid msg- putWord32le $ idiag_inode msg---- TODO add support for OWDs-getInetDiagSockid :: Get InetDiagSockId-getInetDiagSockid = do- sport <- getWord16host- dport <- getWord16host- -- iterate/ grow- _src <- getByteString (4*4)- _dst <- getByteString (4*4)- _intf <- getWord32host- 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- putWord16be $ idiag_sport cust- putWord16be $ idiag_dport cust- putByteString (idiag_src cust)- putByteString (idiag_dst cust)- putWord32host $ idiag_intf cust- putWord64host $ idiag_cookie cust---getDiagVegasInfo :: Get SockDiagExtension-getDiagVegasInfo =- TcpVegasInfo <$> getWord32host <*> getWord32host <*> getWord32host <*> getWord32host---- TODO generate via FFI ?-eIPPROTO_TCP :: Word8-eIPPROTO_TCP = 6---{-|-Different answers described in include/uapi/linux/inet_diag.h-Please keep the spacing the same as --}-data SockDiagExtension =- -- | Exact copy of kernel's struct tcp_info- -- tcp_diag_get_info- DiagTcpInfo {- tcpi_state :: Word8,- tcpi_ca_state :: Word8,- tcpi_retransmits :: Word8,- tcpi_probes :: Word8,- tcpi_backoff :: Word8,- tcpi_options :: Word8,- tcpi_wscales :: Word8 -- ^both sender and receiver on 4 bits- , tcpi_delivery_rate_app_limited :: Word8 -- ^but only first bit used-- , tcpi_rto :: Word32,- tcpi_ato :: Word32,- tcpi_snd_mss :: Word32,- tcpi_rcv_mss :: Word32,-- tcpi_unacked :: Word32,- tcpi_sacked :: Word32,- tcpi_lost :: Word32,- tcpi_retrans :: Word32,- tcpi_fackets :: Word32,-- -- Time- tcpi_last_data_sent :: Word32,- tcpi_last_ack_sent :: Word32,- tcpi_last_data_recv :: Word32,- tcpi_last_ack_recv :: Word32,-- -- Metric- tcpi_pmtu :: Word32,- tcpi_rcv_ssthresh :: Word32,- tcpi_rtt :: Word32,- tcpi_rttvar :: Word32,- tcpi_snd_ssthresh :: Word32,- tcpi_snd_cwnd :: Word32,- tcpi_advmss :: Word32,- tcpi_reordering :: Word32,-- tcpi_rcv_rtt :: Word32,- tcpi_rcv_space :: Word32-- , tcpi_total_retrans :: Word32-- , tcpi_pacing_rate :: Word64- , tcpi_max_pacing_rate :: Word64- , tcpi_bytes_acked :: Word64- , tcpi_bytes_received :: Word64- , tcpi_segs_out :: Word32- , tcpi_segs_in :: Word32-- , tcpi_notsent_bytes :: Word32- , tcpi_min_rtt :: Word32- , tcpi_data_segs_in :: Word32- , tcpi_data_segs_out :: Word32-- , tcpi_delivery_rate :: Word64-- , tcpi_busy_time :: Word64- , tcpi_rwnd_limited :: Word64- , tcpi_sndbuf_limited :: Word64-- , tcpi_delivered :: Word32- , tcpi_delivered_ce :: Word32-- , tcpi_bytes_sent :: Word64- , tcpi_bytes_retrans :: Word64- , tcpi_dsack_dups :: Word32- , tcpi_reord_seen :: Word32-- -- Extended version, hoping it doesn't break too much stuff- , tcpi_snd_cwnd_clamp :: Word32- , tcpi_fowd :: Word32- , tcpi_bowd :: Word32--} | DiagExtensionMemInfo {- idiag_rmem :: Word32 -- ^ Amount of data in the receive queue.-, idiag_wmem :: Word32 -- ^ amount of data that is queued by TCP but not yet sent.-, idiag_fmem :: Word32 -- ^ amount of memory scheduled for future use-, idiag_tmem :: Word32 -- ^ amount of data in send queue.-} |- -- | Not exclusive to Vegas unlike the name indicates, mirrors tcpvegas_info- TcpVegasInfo {- tcpInfoVegasEnabled :: Word32- , tcpInfoRttCount :: Word32- , tcpInfoRtt :: Word32- , tcpInfoMinrtt :: Word32-} | CongInfo String- | SockDiagShutdown Word8- -- Apparently used to pass BBR data- | SockDiagMark Word32- deriving (Show, Generic)---- ideally we should be able to , Serialize--- instance Convertable SockDiagExtension where--- getGet _ = get--- getPut = put---getTcpVegasInfo :: Get SockDiagExtension-getTcpVegasInfo = TcpVegasInfo <$> getWord32host <*> getWord32host <*> getWord32host <*> getWord32host--getMemInfo :: Get SockDiagExtension-getMemInfo = DiagExtensionMemInfo <$> getWord32host <*> getWord32host <*> getWord32host <*> getWord32host--getDiagMark :: Get SockDiagExtension-getDiagMark = SockDiagMark <$> getWord32host---getShutdown :: Get SockDiagExtension-getShutdown = SockDiagShutdown <$> getWord8---- | Get congestion control name-getCongInfo :: Get SockDiagExtension-getCongInfo = do- left <- remaining- bs <- getByteString left- return (CongInfo $ unpack $ init bs)---getDiagTcpInfo :: Get SockDiagExtension-getDiagTcpInfo = DiagTcpInfo <$> getWord8 <*> getWord8 <*> getWord8 <*> getWord8 <*> getWord8 <*> getWord8 <*> getWord8 <*> getWord8- <*> getWord32host <*> getWord32host <*> getWord32host <*> getWord32host- <*> getWord32host <*> getWord32host <*> getWord32host <*> getWord32host <*> getWord32host- -- times- <*> getWord32host <*> getWord32host <*> getWord32host <*> getWord32host- -- metrics- <*> getWord32host <*> getWord32host <*> getWord32host <*> getWord32host- <*> getWord32host <*> getWord32host <*> getWord32host <*> getWord32host--- <*> getWord32host <*> getWord32host-- -- tcpi_total_retrans- <*> getWord32host-- -- starts at tcpi_pacing_rate- <*> getWord64host <*> getWord64host <*> getWord64host <*> getWord64host- <*> getWord32host <*> getWord32host-- -- starts at tcpi_notsent_bytes- <*> getWord32host <*> getWord32host <*> getWord32host <*> getWord32host-- -- tpci_delivery_rate- <*> getWord64host-- <*> getWord64host <*> getWord64host<*> getWord64host-- -- tcpi_delivered- <*> getWord32host <*> getWord32host-- -- tcpi_bytes_sent- <*> getWord64host<*> getWord64host <*> getWord32host <*> getWord32host-- -- My custom addition to read the owds, it's an extra that should be removed - -- for a vanilla kernel- <*> getWord32host <*> getWord32host <*> getWord32host---- Sends a SockDiagRequest--- expects INetDiag--- TODO should take an Mptcp connection into account--- We should use cookies later on--- MaybeCookie ?--- TcpConnection -- ^Connection we are requesting--- #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)))--- stateFilter = [TcpListen, TcpEstablished, TcpSynSent ]---- InetDiagInfo--- TODO we need to request more !--- TODO if we have a cookie ignore the rest ?!--- requestedInfo = InetDiagNone--showExtension :: SockDiagExtension -> String-showExtension (CongInfo cc) = "Using CC " ++ (show cc)-showExtension (TcpVegasInfo _ _ rtt minRtt) = "RTT=" ++ (show rtt) ++ " minRTT=" ++ show minRtt-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--{- 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-- diag_req = case selector of- -- TODO- Left cookie -> let- bstr = pack $ replicate 128 (0 :: Word8)- in- InetDiagSockId 0 0 bstr bstr 0 cookie-- Right con -> let- ipSrc = runPut $ putIPAddress (srcIp con)- ipDst = runPut $ putIPAddress (dstIp con)- ifIndex = subflowInterface con- _cookie = 0 :: Word64- in- InetDiagSockId (srcPort con) (dstPort con) ipSrc ipDst (fromJust ifIndex) _cookie-- custom = SockDiagRequest eAF_INET eIPPROTO_TCP requestedInfo tcpStatesFilter diag_req- in- Packet hdr custom Map.empty---- | to search for a specific connection-queryPacketFromCookie :: Word64 -> Packet SockDiagRequest-queryPacketFromCookie cookie = genQueryPacket (Left cookie) [] []---loadExtension :: Int -> ByteString -> Maybe SockDiagExtension-loadExtension key value = let- eExtId = (toEnum key :: SockDiagExtensionId)- fn = case toEnum key of- -- MessageType shouldn't matter anyway ?!- InetDiagCong -> Just getCongInfo- -- InetDiagNone -> Nothing- InetDiagInfo -> Just getDiagTcpInfo- InetDiagVegasinfo -> Just getTcpVegasInfo- -- InetDiagTos -> Nothing- -- InetDiagTclass -> Nothing- -- InetDiagSkmeminfo -> Nothing- InetDiagShutdown -> Just getShutdown- InetDiagMeminfo -> Just getMemInfo- -- InetDiagDctcpinfo -> Nothing- -- InetDiagProtocol -> Nothing- -- InetDiagSkv6only -> Nothing- -- InetDiagLocals -> Nothing- -- InetDiagPeers -> Nothing- -- InetDiagPad -> Nothing- -- requires CAP_NET_ADMIN- InetDiagMark -> Just getDiagMark- -- InetDiagBbrinfo -> Nothing- -- InetDiagClassId -> Nothing- -- InetDiagMd5sig -> Nothing- -- InetDiagMax -> Nothing- _ -> Nothing- -- _ -> case decode value of- -- Right x -> Just x- -- -- Left err -> error $ "fourre-tout error " ++ err- -- Left err -> Nothing-- in case fn of- Nothing -> Nothing- Just getFn -> case runGet getFn value of- Right x -> Just $ x- Left err -> error $ "error decoding " ++ show eExtId ++ ":\n" ++ err-
− Net/Tcp.hs
@@ -1,20 +0,0 @@-{-# OPTIONS_GHC -fno-warn-orphans #-}-{-|-Module : TCP-Description : Implementation of mptcp netlink path manager-Maintainer : matt-Stability : testing-Portability : Linux---}-module Net.Tcp (- module Net.Tcp.Definitions- , module Net.Tcp.Constants-) where--import Net.Tcp.Definitions-import Net.Tcp.Constants-import Net.Bitset---instance ToBitMask TcpFlag
− Net/Tcp/Definitions.hs
@@ -1,76 +0,0 @@-{-# LANGUAGE NoImplicitPrelude #-}-{-# LANGUAGE OverloadedStrings #-}-module Net.Tcp.Definitions (- TcpConnection (..)- , ConnectionRole (..)- , reverseTcpConnection- , showTcpConnection-)--where--import Prelude-import Net.IP-import Data.Aeson-import Data.Word (Word8, Word16, Word32)-import GHC.Generics-import qualified Data.Text as TS--{- Describe a TCP connection, possibly an Mptcp subflow- The equality implementation ignores several fields--}-data TcpConnection = TcpConnection {- -- TODO use libraries to deal with that ? filter from the command line for instance ?- srcIp :: IP -- ^Source ip- , dstIp :: IP -- ^Destination ip- , srcPort :: Word16 -- ^ Source port- , dstPort :: Word16 -- ^Destination port- , priority :: Maybe Word8 -- ^subflow priority- , localId :: Word8 -- ^ Convert to AddressFamily- , remoteId :: Word8- -- TODO remove could be deduced from srcIp / dstIp ?- , subflowInterface :: Maybe Word32 -- ^Interface of Maybe ? why a maybe ?- -- add TcpMetrics member- -- , tcpMetrics :: Maybe [SockDiagExtension] -- ^Metrics retrieved from kernel--} deriving (Show, Generic, Ord)--tshow :: Show a => a -> TS.Text-tshow = TS.pack . Prelude.show--data ConnectionRole = Server | Client deriving (Show, Eq)---showTcpConnectionText :: TcpConnection -> TS.Text-showTcpConnectionText con =- showIp ( srcIp con) <> ":" <> tshow (srcPort con) <> " -> " <> showIp (dstIp con) <> ":" <> tshow (dstPort con)- where- showIp = Net.IP.encode--showTcpConnection :: TcpConnection -> String-showTcpConnection = TS.unpack . showTcpConnectionText---reverseTcpConnection :: TcpConnection -> TcpConnection-reverseTcpConnection con = con {- srcIp = dstIp con- , dstIp = srcIp con- , srcPort = dstPort con- , dstPort = srcPort con- , priority = Nothing- , localId = remoteId con- , remoteId = localId con- , subflowInterface = Nothing-}--instance FromJSON TcpConnection-instance ToJSON TcpConnection---- TODO create a specific function for it--- ignore the rest-instance Eq TcpConnection where- x == y = srcIp x == srcIp y && dstIp x == dstIp y- && srcPort x == srcPort y && dstPort x == dstPort y- -- /= = not ==--
README.md view
@@ -1,3 +1,5 @@+[![Hackage][hk-img]][hk]+ This is a userspace path manager for the [linux multipath TCP kernel][mptcp-fork], starting from version v0.95. @@ -35,7 +37,7 @@ ``` $ nix develop-$ cabal run daemon+$ cabal run mptcp-manager ``` # TODO@@ -51,5 +53,7 @@ This work is sponsored by [NGI][ngi]. +[hk-img]: https://img.shields.io/hackage/v/mptcp-pm.svg?logo=haskell+[hk]: https://hackage.haskell.org/package/mptcp-pm [mptcp-fork]: http://multipath-tcp.org/ [ngi]: https://www.ngi.eu/
− hs/daemon.hs
@@ -1,880 +0,0 @@-{-|-Description : Implementation of mptcp netlink path manager-Maintainer : matt-Stability : testing-Portability : Linux--This userspace program is a complement to the linux MPTCP kernel developed at-https://github.com/multipath-tcp/mptcp--The main daemon monitors MPTCP connections and for each new connection assigns a thread-to mino.---The daemon main thread has 2 roles:-- monitors interface change (network interface addition/deletion)-- listens to--Monitors new MPTCP connections and runs a specific monitor instance-To interact-GENL_ADMIN_PERM-The operation requires the CAP_NET_ADMIN privilege-iproute2/misc/ss.c to see how `ss` utility interacts with the kernel--}-{-# LANGUAGE OverloadedStrings #-}-{-# OPTIONS_GHC -fno-warn-orphans #-}--module Main where--import Net.SockDiag-import Net.Mptcp-import Net.Mptcp.PathManager-import Net.Mptcp.PathManager.Default-import Net.Tcp-import Net.IP-import Net.SockDiag.Constants-import Net.Mptcp.Constants--import Text.Read (readMaybe)-import Data.Text ()-import Prelude hiding (concat, init)-import Options.Applicative hiding (value, ErrorMsg, empty)-import qualified Options.Applicative (value)-import Control.Monad.Trans (liftIO)-import Control.Monad.Trans.State (State, StateT, put, get,- execStateT)-import Control.Monad (foldM)-import Data.Maybe (catMaybes)-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-import qualified System.Linux.Netlink.Simple as NLS-import qualified System.Linux.Netlink.Route as NLR--import System.Process-import System.Exit-import Data.Word (Word32)--- import qualified Data.Bits as Bits -- (shiftL, )--- import Data.Bits ((.|.))-import Data.Serialize.Get (runGet)-import Data.Serialize.Put--- import Data.Either (fromRight)-import Data.ByteString (ByteString)-import qualified Data.ByteString.Lazy as BL-import qualified Data.Map as Map-import qualified Data.Set as Set--- import qualified Data.Text-import Data.Bits (Bits(..))-import Debug.Trace-import Control.Concurrent--- import System.IO.Unsafe-import System.IO.Temp ()-import System.FilePath ()-import Numeric.Natural-import System.IO (stderr)-import Data.Aeson--- to merge MptcpConnection export and Metrics-import Data.Aeson.Extra.Merge (lodashMerge)-import GHC.List (init)---- for getEnvDefault, to get TMPDIR value.--- we could pass it as an argument--- import System.Environment.Blank(getEnvDefault)--import System.Log.Logger (- infoM- , debugM- , errorM- , Priority(DEBUG)- , Priority(INFO)- , setLevel, updateGlobalLogger- , setHandlers- , rootLoggerName- -- , saveGlobalLogger- -- , addHandler- )-import System.Log.Handler.Simple (- verboseStreamHandler- )----- |Delay between 2 successful loggings-onSuccessSleepingDelayMs :: Natural-onSuccessSleepingDelayMs = 300----- | When it couldn't set the correct value-onFailureSleepingDelay :: Natural-onFailureSleepingDelay = 100---- |the default path manager-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-- -- |Connections to accept, loaded via cli's --filter- , filteredConnections :: Maybe [TcpConnection]-}-- -- https://stackoverflow.com/questions/3640120/combine-state-with-io-actions-type GState a = State MyState a---- 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---dumpCommand :: MptcpGenlEvent -> String-dumpCommand x = show x ++ " = " ++ show (fromEnum x)--dumpMptcpCommands :: MptcpGenlEvent -> String-dumpMptcpCommands MPTCP_CMD_EXIST = dumpCommand MPTCP_CMD_EXIST-dumpMptcpCommands x = dumpCommand x ++ "\n" ++ dumpMptcpCommands (succ x)---data CLIArguments = CLIArguments {-- -- | 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 :: Maybe FilePath-- -- | to filter- , filter :: Maybe FilePath-- -- | Folder where to log files- , out :: FilePath-- -- , clientIP :: IPv4- , quiet :: Bool-- -- Priority- , logLevel :: Priority- }---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"---sample :: Parser CLIArguments-sample = CLIArguments- <$> (optional $ strOption- ( long "optimizer"- <> short 'p'- <> help "Path to the userspace program"- <> metavar "PROGRAM" ))- <*> (optional $ strOption- ( long "filter"- <> help "Path to a json file describing a TCP connection"- <> metavar "Filter" ))- <*> strOption- ( long "out"- <> short 'o'- <> help "Where to store the files"- <> showDefault- <> Options.Applicative.value "/tmp"- <> metavar "PROGRAM" )- <*> switch- ( long "verbose"- <> short 'v'- <> help "Whether to be quiet" )- <*> option auto- ( long "log-level"- <> help "Log level"- <> showDefault- <> Options.Applicative.value INFO- <> metavar "LOG_LEVEL" )---opts :: ParserInfo CLIArguments-opts = info (sample <**> helper)- ( fullDesc- <> progDesc "Print a greeting for TARGET"- <> header "hello - a test for optparse-applicative" )------ inspired by makeNL80211Socket Create a 'NL80211Socket' this opens a genetlink--- socket and gets the family id--- TODO should record the token too--- TODO should join the group !!-makeMptcpSocket :: IO MptcpSocket-makeMptcpSocket = do- -- for legacy reasons this opens a route socket- sock <- GENL.makeSocket- 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))----makeMetricsSocket :: IO NetlinkSocket-makeMetricsSocket = makeSocketGeneric eNETLINK_SOCK_DIAG----- A utility function - threadDelay takes microseconds, which is slightly annoying.-sleepMs :: Natural -> IO()-sleepMs n = threadDelay $ (fromIntegral n :: Int) * 1000----- | here we may want to run mptcpnumerics to get some results-updateSubflowMetrics :: NetlinkSocket -> TcpConnection -> IO SockDiagMetrics-updateSubflowMetrics sockMetrics subflow = do- putStrLn "Updating subflow metrics"- let queryPkt = genQueryPacket (Right subflow) [TcpListen, TcpEstablished]-- [InetDiagCong, InetDiagInfo, InetDiagMeminfo]- sendPacket sockMetrics queryPkt-- putStrLn "Sent the TCP SS request"- putStrLn "Starting inspecting answers"-- answers <- recvMulti sockMetrics- let metrics_m = inspectIdiagAnswers answers- -- filter ? keep only valud ones ?- return $ head (catMaybes metrics_m)--isFlagSet :: Bits a => a -> a -> Bool-isFlagSet f v = (f .&. v) == f---- Copy/pasted from System.Linux.Netlink--- |Internal function to receive multiple netlink messages-recvMulti :: (Convertable a, Eq a, Show a) => NetlinkSocket -> IO [Packet a]-recvMulti sock = do- pkts <- recvOne sock- if isMulti (first pkts)- then if isDone (last pkts)- -- This is fine because first would have complained before- then return $ init pkts- else (pkts ++) <$> recvMulti sock- else return pkts- where- isMulti = isFlagSet fNLM_F_MULTI . messageFlags . packetHeader- isDone = (== eNLMSG_DONE) . messageType . packetHeader- first (x:_) = x- first [] = error "Got empty list from recvOne in recvMulti, this shouldn't happen"--{- |- Starts monitoring a specific MPTCP connection- Maybe should expect a pathManager instance (and logger-FilePath -- ^Path towards the program to get cwnd limits--}-startMonitorConnection :: CLIArguments- -- | elapsed time since starting the thread (very coarse approximation)- -> Natural- -> MptcpSocket- -> NetlinkSocket- -> MVar MptcpConnection -> IO ()-startMonitorConnection cliArgs elapsed mptcpSock sockMetrics mConn = do- let (MptcpSocket sock _) = mptcpSock- myId <- myThreadId- putStr $ show myId ++ ": monitoring connection at *time* " ++ show elapsed ++ " ..."- -- as long as conn is not empty we keep going ?- -- for this connection- -- query metrics for the whole MPTCP connection- mptcpConn <- readMVar mConn- putStrLn "Showing MPTCP connection"- putStrLn $ show mptcpConn ++ "..."- let _token = connectionToken mptcpConn- let tmpdir = out cliArgs-- -- TODO this is the issue- -- not sure it's the master with a set- let _masterSf = Set.elemAt 0 (subflows mptcpConn)-- -- Get updated metrics- lastMetrics <- mapM (updateSubflowMetrics sockMetrics) (Set.toList $ subflows mptcpConn)- let filename = tmpdir ++ "/" ++ "mptcp_" ++ show (connectionToken mptcpConn) ++ "_" ++ show elapsed ++ ".json"- -- logStatistics filename elapsed mptcpConn lastMetrics-- duration <- case optimizer cliArgs of- Nothing -> return onSuccessSleepingDelayMs- Just program -> do-- debugM "main" "Calling third party program"-- cwnds_m <- getCapsForConnection filename program mptcpConn lastMetrics- -- rename to waitingTime ? delay- case cwnds_m of- Nothing -> do- errorM "main" "Couldn't fetch the values"- return onFailureSleepingDelay- Just cwnds -> do-- debugM "main" $ "Requesting to set cwnds..." ++ show cwnds- -- TODO fix- -- KISS for now (capCwndPkt mptcpSock )- let cwndPackets = map (\(cwnd, sf) -> capCwndPkt mptcpSock mptcpConn cwnd sf) (zip cwnds (Set.toList $ subflows mptcpConn))-- mapM_ (sendPacket sock) cwndPackets-- return onSuccessSleepingDelayMs- debugM "main" $ "Finished monitoring token. Waiting " ++ show duration- sleepMs duration-- -- call ourself again- startMonitorConnection cliArgs (elapsed + duration) mptcpSock sockMetrics mConn----{-- | 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 -- ^Statistics file- -> FilePath -- ^Path towards the PM optimizer- -> MptcpConnection- -> [SockDiagMetrics]- -> IO (Maybe [Word32])-getCapsForConnection filename program mptcpConn metrics = do-- let subflowCount = length $ subflows mptcpConn-- -- Data.ByteString.Lazy.writeFile filename jsonBs-- -- readProcessWithExitCode binary / args / stdin- (exitCode, stdout, stderrContent) <- readProcessWithExitCode program [filename, show subflowCount] ""-- infoM "main" $ "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 -> (readMaybe stdout) :: Maybe [Word32]- ExitFailure val -> error $ "stdout:" ++ stdout ++ " stderr: " ++ stderrContent- )- return values---- the library contains showAttrs / showNLAttrs-showAttributes :: Attributes -> String-showAttributes attrs =- let- mapped = Map.foldrWithKey (\k v -> (dumpAttribute k v ++) ) "\n " attrs- in- mapped--putW32 :: Word32 -> ByteString-putW32 x = runPut (putWord32host x)----- I want to override the GenlHeader version-newtype GenlHeaderMptcp = GenlHeaderMptcp GenlHeader-instance Show GenlHeaderMptcp where- show (GenlHeaderMptcp (GenlHeader cmd ver)) =- "Header: Cmd = " ++ show cmd ++ ", Version: " ++ show ver ++ "\n"-----inspectAnswers :: [GenlPacket NoData] -> IO ()-inspectAnswers packets = do- mapM_ inspectAnswer packets- debugM "main" "Finished inspecting answers"---- showPacketCustom :: GenlPacket NoData -> String--- showPacketCustom pkt = let--- hdr = (genlDataHeader pkt )--- in showPacket pkt--showHeaderCustom :: GenlHeader -> String-showHeaderCustom = show--inspectAnswer :: GenlPacket NoData -> IO ()-inspectAnswer (Packet _ (GenlData hdr NoData) attributes) = let- cmd = genlCmd hdr- in- debugM "main" $ "Inspecting answer custom:\n" ++ showHeaderCustom hdr- ++ "Supposing it's a mptcp command: " ++ dumpCommand ( toEnum $ fromIntegral cmd)--inspectAnswer pkt = putStrLn $ "Inspecting answer:\n" ++ showPacket pkt----- should have this running in parallel-queryAddrs :: NLR.RoutePacket-queryAddrs = NL.Packet- (NL.Header NLC.eRTM_GETADDR (NLC.fNLM_F_ROOT .|. NLC.fNLM_F_MATCH .|. NLC.fNLM_F_REQUEST) 0 0)- (NLR.NAddrMsg 0 0 0 0 0)- mempty----- |Deal with events for already registered connections--- Warn: MPTCP_EVENT_ESTABLISHED registers a "null" interface--- or a list of packets to send----- TODO maybe the path manager should be part of the MptcpConnection-dispatchPacketForKnownConnection :: MptcpSocket- -> MptcpConnection- -> MptcpGenlEvent- -> Attributes- -> AvailablePaths- -> (Maybe MptcpConnection, [MptcpPacket])-dispatchPacketForKnownConnection mptcpSock con event attributes availablePaths = let- token = connectionToken con- subflow = subflowFromAttributes attributes- in- case event of-- -- 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)-- -- TODO trigger the pathManager again, fix the remote interpretation- MPTCP_EVENT_ANNOUNCED -> let- -- what if it's local- remId = remoteIdFromAttributes attributes- -- newConn = mptcpConnAddRemoteId con remId- newConn = con- in- (Just newConn, [])-- MPTCP_EVENT_CLOSED -> (Nothing, [])-- MPTCP_EVENT_SUB_ESTABLISHED -> let- newCon = mptcpConnAddSubflow con subflow- in- (Just newCon,[])- -- let newState = oldState- -- putMVar con newCon- -- let newState = oldState { connections = Map.insert token newCon (connections oldState) }- -- TODO we should insert the- -- newConn <-- -- return newState-- -- TODO remove- MPTCP_EVENT_SUB_CLOSED -> let- newCon = mptcpConnRemoveSubflow con subflow- in- (Just newCon, [])-- -- MPTCP_CMD_EXIST -> con- _ -> error $ "should not happen " ++ show event----- |Filter connections--- This should be configurable in some way-acceptConnection :: TcpConnection -> Maybe [TcpConnection] -> Bool-acceptConnection subflow mFilteredConnections =- case mFilteredConnections of- Nothing -> True- -- or notElem- Just filtered -> subflow `elem` filtered---- |-mapSubflowToInterfaceIdx :: IP -> IO (Maybe Word32)-mapSubflowToInterfaceIdx ip = do-- res <- tryReadMVar globalInterfaces- case res of- Nothing -> error "Couldn't access the list of interfaces"- Just interfaces -> return $ mapIPtoInterfaceIdx interfaces ip----registerMptcpConnection :: MptcpToken -> TcpConnection -> StateT MyState IO ()-registerMptcpConnection token subflow = (do- oldState <- get- let (MyState mptcpSock conns cliArgs filtered) = oldState- if acceptConnection subflow filtered == False- then do- -- infoM "main" $ "filtered out connection:" ++ show subflow- return ()- else (do- -- putStrLn $ "accepted connection :" ++ show subflow- -- should we add the subflow yet ? it doesn't have the correct interface idx- mappedInterface <- liftIO $ mapSubflowToInterfaceIdx (srcIp subflow)- let fixedSubflow = subflow { subflowInterface = mappedInterface }- -- let newMptcpConn = (MptcpConnection token [] Set.empty Set.empty)- let newMptcpConn = mptcpConnAddSubflow (- MptcpConnection token Set.empty Set.empty Set.empty (optimizer cliArgs)- ) fixedSubflow-- newConn <- liftIO $ newMVar newMptcpConn- -- putStrLn $ "Connection established !!\n"-- -- create a new- sockMetrics <- liftIO $ makeMetricsSocket- -- start monitoring connection- threadId <- liftIO $ forkOS (startMonitorConnection cliArgs 0 mptcpSock sockMetrics newConn)-- -- putStrLn $ "Inserting new MVar "- put (oldState {- connections = Map.insert token (threadId, newConn) (connections oldState)- })- ))---- |Treat MPTCP events depending on if the connection is known or not-dispatchPacket :: MyState -> MptcpPacket -> IO MyState-dispatchPacket oldState (Packet hdr (GenlData genlHeader NoData) attributes) = let- cmd = toEnum $ fromIntegral $ genlCmd genlHeader- (MyState mptcpSock conns _ _) = oldState- (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 do- putStrLn $ "Fetching available paths"- availablePaths <- readMVar globalInterfaces-- putStrLn $ "dispatch cmd " ++ show cmd ++ " for token " ++ show token-- case maybeMatch of- -- Unknown token- Nothing -> do-- 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- execStateT (registerMptcpConnection token subflow) oldState- _ -> return oldState-- Just (threadId, mvarConn) -> do- putStrLn $ "MATT: Received request for a known connection "- mptcpConn <- takeMVar mvarConn-- 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) }-- (Just newConn, pkts) -> do- putStrLn "putting mVar"- putMVar mvarConn newConn- -- TODO update state-- 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-- -- 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- 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) =- putStrLn $ "Error msg of type " ++ showErrCode errCode ++ " Packet content:\n"-showError _ = error "Not the good overload"---- netlink must contain sthg for it--- /usr/include/asm/errno.h-showErrCode :: CInt -> String-showErrCode err- | Errno err == ePERM = "EPERM"- | Errno err == eOK = "EOK"- | otherwise = show err---- showErrCode err = case err of--- -- show err--- ePERM -> "EPERM"--- eNOTCONN -> "NOT connected"--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- results <- recvOne' simpleSock :: IO [Either String MptcpPacket]- -- TODO retrieve packets- -- here we should update the state according- -- mapM_ (inspectResult myState) results- -- (Foldable t, Monad m) => (b -> a -> m b) -> b -> t a -> m b- modifiedState <- foldM inspectResult myState results- doDumpLoop modifiedState---listenToEvents :: MyState -> CtrlAttrMcastGroup -> IO ()-listenToEvents state my_group = do- joinMulticastGroup sock (grpId my_group)- putStrLn $ "Joined grp " ++ grpName my_group- _ <- doDumpLoop state- putStrLn "end of listenToEvents"- where- (MptcpSocket sock fid) = socket state----- testing-listenToMetricEvents :: NetlinkSocket -> CtrlAttrMcastGroup -> IO ()-listenToMetricEvents sock myGroup = do- putStrLn "listening to metric events"- joinMulticastGroup sock (grpId myGroup)- putStrLn $ "Joined grp " ++ grpName myGroup- -- _ <- doDumpLoop globalState- -- putStrLn "TOTO"- -- where- -- -- mptcpSocket = MptcpSocket sock fid- -- globalState = MyState mptcpSocket Map.empty---dumpExtensionAttribute :: Int -> ByteString -> SockDiagExtension-dumpExtensionAttribute attrId value = let- eExtId = (toEnum attrId :: SockDiagExtensionId)- ext_m = loadExtension attrId value- in- case ext_m of- Nothing -> error $ "Could not load " ++ show eExtId ++ " (unsupported)\n"- Just ext -> ext- -- traceId (show eExtId) ++ " " ++ showExtension ext ++ " \n"--loadExtensionsFromAttributes :: Attributes -> [SockDiagExtension]-loadExtensionsFromAttributes attrs =- let- mapped = Map.foldrWithKey (\k v -> ([dumpExtensionAttribute k v] ++ )) [] attrs- in- mapped---{- Parses the requested informations--}-inspectIDiagAnswer :: Packet SockDiagMsg -> Maybe SockDiagMetrics-inspectIDiagAnswer (Packet hdr cus attrs) =- Just $ SockDiagMetrics cus (loadExtensionsFromAttributes attrs)- -- Just cus-inspectIDiagAnswer p = Nothing---- inspectIDiagAnswer (DoneMsg err) = putStrLn "DONE MSG"--- (GenlData NoData)--- inspectIdiagAnswer (Packet hdr (GenlData ghdr NoData) attributes) = putStrLn $ "Inspecting answer:\n"--- inspectIdiagAnswer (Packet _ (GenlData hdr NoData) attributes) = let--- cmd = genlCmd hdr--- in--- putStrLn $ "Inspecting answer custom:\n" ++ showHeaderCustom hdr--- ++ "Supposing it's a mptcp command: " ++ dumpCommand ( toEnum $ fromIntegral cmd)----- |Convenience wrapper-data SockDiagMetrics = SockDiagMetrics {- sockDiagMsg :: SockDiagMsg- -- subflowSubflow :: TcpConnection- , sockdiagMetrics :: [SockDiagExtension]-}---- type SockDiagExtension2 = SockDiagExtension-instance ToJSON SockDiagExtension where- toJSON (tcpInfo@DiagTcpInfo {} ) = let- -- rtt = tcpi_rtt tcpInfo- tcpState = toEnum $ fromIntegral ( tcpi_state tcpInfo) :: TcpState- -- TODO could log ca_state ?-- in- object [- "rttvar" .= tcpi_rttvar tcpInfo- , "rtt_us" .= tcpi_rtt tcpInfo- , "rto_us" .= tcpi_rto tcpInfo- , "snd_cwnd" .= tcpi_snd_cwnd tcpInfo- , "snd_cwnd_clamp" .= tcpi_snd_cwnd_clamp tcpInfo- , "snd_ssthresh" .= tcpi_snd_ssthresh tcpInfo- , "reordering" .= tcpi_reordering tcpInfo- , "tcp_state" .= show tcpState- , "pacing" .= tcpi_pacing_rate tcpInfo- , "delivery_rate" .= tcpi_delivery_rate tcpInfo- , "app_limited" .= tcpi_delivery_rate_app_limited tcpInfo- -- there is also a delivered_ce ?- , "delivered" .= tcpi_delivered tcpInfo- , "lost" .= tcpi_lost tcpInfo- , "retrans" .= tcpi_retrans tcpInfo- , "min_rtt" .= tcpi_min_rtt tcpInfo- , "mtu" .= tcpi_pmtu tcpInfo- -- TODO try converting it to str- , "ca_state" .= tcpi_ca_state tcpInfo-- -- bytes_sent- -- needs kernel patching- -- , "fowd" .= toJSON ( (fromIntegral rtt/2) :: Float)- -- , "bowd" .= toJSON ( (fromIntegral rtt/2) :: Float)-- , "fowd" .= tcpi_fowd tcpInfo- , "bowd" .= tcpi_bowd tcpInfo--- -- , "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 []---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- initialValue = object [- "srcIp" .= toJSON (srcIp sf)- , "dstIp" .= toJSON (dstIp sf)- , "srcPort" .= toJSON (srcPort sf)- , "dstPort" .= toJSON (dstPort sf)- -- doesnt work as subflow id- -- , "subflow_id" .= idiag_uid msg- ]- fn x y = lodashMerge (toJSON x) y-- 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---main :: IO ()-main = do-- -- SETUP LOGGING (https://gist.github.com/ijt/1052896)- -- streamHandler vs verboseStreamHandler- myStreamHandler <- verboseStreamHandler stderr INFO- updateGlobalLogger rootLoggerName (setLevel DEBUG . setHandlers [myStreamHandler])-- infoM "main" "Parsing command line..."- options <- execParser opts- infoM "main" "Creating MPTCP netlink socket..."--- infoM "main" "Now Tracking system interfaces..."- putMVar globalInterfaces Map.empty- routeNl <- forkIO trackSystemInterfaces-- debugM "main" "socket created. MPTCP Family id "-- mptcpSocket <- makeMptcpSocket- let (MptcpSocket sock fid) = mptcpSocket- mcastMptcpGroups <- getMulticastGroups sock fid- mapM_ Prelude.print mcastMptcpGroups--- filteredConns <- case Main.filter options of- Nothing -> return Nothing- Just filename -> do- infoM "main" ("Loading connections whitelist from " ++ filename ++ "...")- filteredConnectionsStr <- BL.readFile filename- case Data.Aeson.eitherDecode filteredConnectionsStr of- -- case Data.Aeson.eitherDecode "[]" of- Left errMsg -> error ("Failed loading " ++ filename ++ ":\n" ++ errMsg)- Right list -> return list-- infoM "main" ("Loading connections whitelisted connections..." ++ (show filteredConns))-- let globalState = MyState mptcpSocket Map.empty options filteredConns-- mapM_ (listenToEvents globalState) mcastMptcpGroups- -- putStrLn $ " Groups: " ++ unwords ( map grpName mcastMptcpGroups )- putStrLn "finished"
mptcp-pm.cabal view
@@ -1,84 +1,137 @@ cabal-version: 3.0 name: mptcp-pm-version: 0.0.3+version: 0.0.4 license: GPL-3.0-only license-file: LICENSE build-type: Simple Maintainer: teto-Category: Network+Category: Network, Mptcp Synopsis: A Multipath TCP path manager Homepage: https://github.com/teto/netlink_pm Description: Multipath TCP (www.multipath-tcp.org) starting from version 0.95 provides a netlink path manager module. This package implements the userspace component in charge of controlling MPTCP subflow establishement and various behaviors.+ It contains a set of function that is also used in [mptcpanalyzer](https://hackage.haskell.org/packages/).+ data-files:-extra-source-files: headers/*.h headers/linux/*.h README.md CHANGELOG+extra-source-files:+ headers/*.h+ headers/linux/*.h+ README.md+ CHANGELOG +++tested-with: GHC == 8.10.7+ Source-repository head type: git location: https://github.com/teto/mptcp-pm +Flag WithPolysemy {+ Description: Add polysemy plugin+ Default: True+} --- Flag Dev {--- Description: Develop with a local netlink library--- Default: True--- }+Flag Dev {+ Description: Relax constraints+ Default: True+} common shared-properties default-language: Haskell2010- -- -fno-warn-unused-imports- -- -fforce-recomp makes it build twice- ghc-options: -Wall -fno-warn-unused-binds -fno-warn-unused-matches- build-depends: netlink >= 1.1.2.0+ ghc-options:+ -Wall -fno-warn-unused-binds -fno-warn-unused-matches -haddock+ build-depends:+ -- TODO remove that boundary+ netlink >= 1.1.1.0+ , formatting+ , readable+ , polysemy+ , polysemy-log+ , polysemy-log-co + default-extensions:+ FlexibleContexts+ , StrictData+ , DataKinds+ , FlexibleContexts+ , GADTs+ , LambdaCase+ -- , OverloadedStrings+ , PolyKinds+ , RankNTypes+ , ScopedTypeVariables+ , TemplateHaskell+ , TypeApplications+ , TypeOperators+ , TypeFamilies + if flag(WithPolysemy)+ ghc-options: -fplugin=Polysemy.Plugin+ build-depends: polysemy-plugin++ library import: shared-properties default-language: Haskell2010 -- for the .chs => c2hs -- apparently this just helps getting a better error messages- Includes: tcp_states.h, linux/sock_diag.h, linux/inet_diag.h, linux/mptcp.h+ Includes:+ tcp_states.h+ , linux/sock_diag.h+ , linux/inet_diag.h+ , linux/mptcp.h -- TODO try to pass it from CLI instead , Net.TcpInfo- include-dirs: headers- default-extensions: DeriveGeneric- autogen-modules: Net.Mptcp.Constants, Net.SockDiag.Constants, Net.Tcp.Constants- build-depends: base >= 4.12 && < 4.17,- containers- , bytestring- -- , fast-logger- , katip- , process- , cereal- , enumset- , ip- , bytestring-conversion- , text- -- todo get rid of it- , mtl- -- for merge- , aeson- , aeson-pretty- , aeson-extra- -- to help with merging json content- , unordered-containers- -- to create temp folder/files- , transformers- hs-source-dirs: .- build-tool-depends: c2hs:c2hs+ include-dirs:+ headers+ default-extensions:+ DeriveGeneric+ -- autogen-modules:+ -- Net.Tcp.Constants+ -- , Net.Mptcp.Constants+ -- , Net.SockDiag.Constants+ build-depends:+ base >= 4.12+ , containers+ , readable+ , bytestring+ , process+ , cereal+ , enumset+ , ip >= 1.7.3+ , bytestring-conversion+ , text+ -- todo get rid of it+ -- for liftIO+ , mtl+ -- for merge+ , aeson+ , aeson-pretty+ , aeson-extra+ -- to help with merging json content+ , unordered-containers+ -- to create temp folder/files+ , transformers+ hs-source-dirs:+ src/+ build-tool-depends:+ c2hs:c2hs Exposed-Modules:- Net.SockDiag+ Net.SockDiag , Net.Tcp , Net.Bitset- , Net.Mptcp- , Net.IPAddress- , Net.Tcp.Definitions , Net.Tcp.Constants- , Net.Mptcp.Constants, Net.SockDiag.Constants- -- TODO let it high level+ , Net.Tcp.Definitions+ , Net.Mptcp+ , Net.Mptcp.Constants , Net.Mptcp.PathManager , Net.Mptcp.PathManager.Default+ , Net.IPAddress+ , Net.SockDiag.Constants+ -- TODO let it high level -- monitor new mptcp connections@@ -86,32 +139,32 @@ executable mptcp-manager import: shared-properties default-language: Haskell2010- -- ghc-options: -prof build-depends: aeson- , aeson-pretty- , aeson-extra- , base >= 4.12 && < 4.17- , bytestring- , containers- , mptcp-pm- , optparse-applicative- , transformers- -- , fast-logger- , hslogger- , ip- , text- , mtl- , cereal- , process- , temporary- , filepath- -- to use Simple module. Try to do without- , netlink >= 1.1.2.0+ , aeson-pretty+ , aeson-extra+ , base >= 4.12 && < 4.17+ , bytestring+ , containers+ , mptcp-pm+ , optparse-applicative+ , transformers+ -- , fast-logger+ -- , hslogger+ , ip+ , text+ , mtl+ , cereal+ , process+ , temporary+ , filepath+ -- to use Simple module. Try to do without+ , netlink >= 1.1.1.0 default-extensions: DeriveGeneric- main-is: daemon.hs- hs-source-dirs: hs/+ main-is: Main.hs+ hs-source-dirs: src/app ghc-options: -threaded -rtsopts+ Test-Suite test-tcp -- 2 types supported, exitcode is based on ... exit codes ....
+ src/Net/Bitset.hs view
@@ -0,0 +1,27 @@+{-# LANGUAGE DefaultSignatures #-}+module Net.Bitset+where+import Control.Monad+import Data.Bits++class ToBitMask a where+ toBitMask :: a -> Int+ -- | Using a DefaultSignatures extension to declare a default signature with+ -- an `Enum` constraint without affecting the constraints of the class itself.+ default toBitMask :: Enum a => a -> Int+ toBitMask = shiftL 1 . fromEnum++instance ( ToBitMask a ) => ToBitMask [a] where+ toBitMask = foldr (.|.) 0 . map toBitMask++-- | Not making this a typeclass, since it already generalizes over all+-- imaginable instances with help of `MonadPlus`.+fromBitMask ::+ ( MonadPlus m, Enum a, Bounded a, ToBitMask a ) =>+ Int -> m a+fromBitMask bm = msum $ map asInBM $ enumFrom minBound+ where+ asInBM a = if isInBitMask bm a then return a else mzero++isInBitMask :: ( ToBitMask a ) => Int -> a -> Bool+isInBitMask bm a = let aBM = toBitMask a in aBM == aBM .&. bm
+ src/Net/IPAddress.hs view
@@ -0,0 +1,79 @@+{-+Module: Net.IPAddress+Description : Description+Maintainer : matt+Portability : Linux++Cereal instances for Net.IP+-}+{-# OPTIONS_GHC -fno-warn-orphans #-}+module Net.IPAddress (+ getAddressFamily+ , getIPFromByteString+ , getIPv4FromByteString+ , getIPv6FromByteString+ , putIPAddress+ )+where+import Data.ByteString+import Data.Serialize.Get+import Data.Serialize.Put+import Net.IP+import Net.IPv4+import Net.IPv6+import System.Linux.Netlink.Constants as NLC++import Control.Monad+++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 =+ let+ val = Net.IPv6.fromWord32s <$> getWord32be <*> getWord32be <*> getWord32be <*> getWord32be+ in+ runGet val bs+++putIPAddress :: IP -> Put+putIPAddress addr =+ case_ putIPv4Address putIPv6Address addr++-- the doc should show the MSB+putIPv6Address :: IPv6 -> Put+putIPv6Address addr =+ let+ (w1, w2, w3, w4) = toWord32s addr+ in do+ putWord32be w1+ putWord32be w2+ putWord32be w3+ putWord32be w4++-- |IDIag version since it will add some padding to reach 128 bits+putIPv4Address :: IPv4 -> Put+putIPv4Address addr =+ let+ w32 = getIPv4 addr+ in do+ putWord32be w32+ replicateM_ 3 (putWord32be 0)+++getAddressFamily :: IP -> AddressFamily+getAddressFamily = case_ (const eAF_INET) (const eAF_INET6)++-- isIPv6 :: IP -> Bool+-- isIPv6 = case_ (const False) (const True)
+ src/Net/Mptcp.hs view
@@ -0,0 +1,486 @@+{-|+Module : Net.Mptcp+Description : Implementation of mptcp netlink path manager+Maintainer : matt+Stability : testing+Portability : Linux++OverloadedStrings allows Aeson to convert+-}+{-# LANGUAGE DeriveGeneric #-}+{-# LANGUAGE OverloadedStrings #-}+module Net.Mptcp (+ -- * Types+ MptcpConnection (..)+ , MptcpPacket+ , MptcpSocket (..)+ , MptcpToken+ , dumpAttribute+ , mptcpConnAddSubflow+ , mptcpConnRemoveSubflow+ , newSubflowPkt+ , capCwndPkt+ , subflowFromAttributes+ , readToken+ , remoteIdFromAttributes+)+where++import Control.Exception (assert)+import Net.SockDiag ()++import qualified Data.Map as Map+import Data.Word (Word16, Word32, Word8)+import System.Linux.Netlink hiding (makeSocket)+-- import System.Linux.Netlink (query, Packet(..))+import System.Linux.Netlink.Constants+import System.Linux.Netlink.GeNetlink+-- import System.Linux.Netlink.GeNetlink.Control+import Data.ByteString (ByteString)+import Data.Maybe (fromJust)++import Data.Serialize.Get+import Data.Serialize.Put++import Data.Bits ((.|.))++import Control.Concurrent ()+import Control.Monad.Trans.State ()+import Data.Aeson+import Data.List ()+import qualified Data.Set as Set+import Debug.Trace+import GHC.Generics+import Net.IP+import Net.IPAddress+import Net.IPv4+import Net.IPv6+import Net.Mptcp.Constants+import Net.Tcp++data MptcpSocket = MptcpSocket NetlinkSocket Word16+instance Show MptcpSocket where+ show sock = let (MptcpSocket _ fid) = sock in ("Mptcp netlink socket: " ++ show fid)++type MptcpPacket = GenlPacket NoData++-- |Same as SockDiagMetrics+-- data SubflowWithMetrics = SubflowWithMetrics {+-- subflowSubflow :: TcpConnection+-- -- for now let's retain DiagTcpInfo only+-- , metrics :: [SockDiagExtension]+-- }++-- |Holds MPTCP level information+data MptcpConnection = MptcpConnection {+ connectionToken :: MptcpToken+ -- use SubflowWithMetrics instead ?!+ -- , subflows :: Set.Set [TcpConnection]+ , subflows :: Set.Set TcpConnection+ , localIds :: Set.Set Word8 -- ^ Announced addresses+ , remoteIds :: Set.Set Word8 -- ^ Announced addresses++ -- Might be reworked/moved in an Enriched/Tracker structure afterwards+ , get_caps_prog :: Maybe FilePath+} deriving (Show, Generic)++-- | Remote port+data RemoteId = RemoteId {++ remoteAddress :: IP+ , remotePort :: Word16+}++++remoteIdFromAttributes :: Attributes -> RemoteId+remoteIdFromAttributes attrs = let+ (SubflowDestPort dport) = fromJust $ makeAttributeFromMaybe MPTCP_ATTR_DPORT attrs+ -- (SubflowFamily _) = 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++-- | 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 ([])+ ]+++-- |Adds a subflow to the connection+-- TODO compose with mptcpConnAddLocalId+mptcpConnAddSubflow :: MptcpConnection -> TcpConnection -> MptcpConnection+mptcpConnAddSubflow mptcpConn sf =+ -- trace ("Adding subflow" ++ show sf)+ mptcpConnAddLocalId+ (mptcpConnAddRemoteId+ (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+ -> MptcpConnection+mptcpConnAddLocalId con locId = con { localIds = Set.insert (locId) (localIds con) }+++-- |Add remote id+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 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+ Left _ -> 0+ 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 _ 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 }+++{-|+ Generates an Mptcp netlink request+TODO we could fake the Word16/Flag and+-}+genMptcpRequest :: Word16 -- ^the family id+ -> MptcpGenlEvent -- ^The MPTCP command+ -> Bool -- ^Dump answer (returns EOPNOTSUPP if not possible)+ -- -> Attributes+ -> [MptcpAttribute]+ -> MptcpPacket+genMptcpRequest fid cmd dump attrs =+ let+ 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+ word8Cmd = fromIntegral (fromEnum cmd) :: Word8++ pkt = Packet myHeader (GenlData geheader NoData) (mptcpListToAttributes attrs)+ -- TODO run an assert on the list filter+ hasTokenAttr = Prelude.any (isAttribute (MptcpAttrToken 0)) attrs+ in+ assert hasTokenAttr pkt++-- | TODO change / return Either+readToken :: ByteString -> Either String MptcpToken+readToken val = runGet getWord32host val++-- LocId => Word8+readLocId :: Maybe ByteString -> LocId+readLocId maybeVal = case maybeVal of+ Nothing -> error "Missing locator id"+ Just val -> case runGet getWord8 val of+ -- TODO generate an error here !+ Left _ -> error "Could not get locId !!"+ Right locId -> locId+ -- runGet getWord8 val++-- doDumpLoop :: MyState -> IO MyState+-- doDumpLoop myState = do+-- let (MptcpSocket simpleSock fid) = socket myState+-- results <- recvOne' simpleSock :: IO [Either String MptcpPacket]+-- -- TODO retrieve packets+-- mapM_ (inspectResult myState) results+-- newState <- doDumpLoop myState+-- 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)++-- 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 | -- ^ should be Word16 too+ -- remote/local ?+ RemoteLocatorId Word8 |+ LocalLocatorId Word8 |+ SubflowSourceAddress IP |+ SubflowDestAddress IP |+ SubflowSourcePort Word16 |+ SubflowDestPort Word16 |+ SubflowMaxCwnd Word32 |+ SubflowBackup Word8 |+ SubflowInterface Word32+ deriving (Show, Eq)++type MptcpToken = Word32+type LocId = Word8++-- inspired by netlink cATA :: CtrlAttribute -> (Int, ByteString)+attrToPair :: MptcpAttribute -> (Int, ByteString)+attrToPair (MptcpAttrToken token) = (fromEnum MPTCP_ATTR_TOKEN, runPut $ putWord32host token)+attrToPair (RemoteLocatorId loc) = (fromEnum MPTCP_ATTR_REM_ID, runPut $ putWord8 loc)+attrToPair (LocalLocatorId loc) = (fromEnum MPTCP_ATTR_LOC_ID, runPut $ putWord8 loc)+attrToPair (SubflowFamily fam) = let+ fam8 = (fromIntegral $ fromEnum fam) :: Word16+ in (fromEnum MPTCP_ATTR_FAMILY, runPut $ putWord16host fam8)++attrToPair ( SubflowInterface idx) = (fromEnum MPTCP_ATTR_IF_IDX, runPut $ putWord32host idx)+attrToPair ( SubflowSourcePort port) = (fromEnum MPTCP_ATTR_SPORT, runPut $ putWord16host port)+attrToPair ( SubflowDestPort port) = (fromEnum MPTCP_ATTR_DPORT, runPut $ putWord16host port)+attrToPair ( SubflowMaxCwnd limit) = (fromEnum MPTCP_ATTR_CWND, runPut $ putWord32host limit)+attrToPair ( SubflowBackup prio) = (fromEnum MPTCP_ATTR_BACKUP, runPut $ putWord8 prio)+-- TODO should depend on the ip putWord32be w32+attrToPair ( SubflowSourceAddress addr) =+ case_ (genV4SubflowAddress MPTCP_ATTR_SADDR4) (genV6SubflowAddress MPTCP_ATTR_SADDR6) addr+attrToPair ( SubflowDestAddress addr) =+ case_ (genV4SubflowAddress MPTCP_ATTR_DADDR4) (genV6SubflowAddress MPTCP_ATTR_DADDR6) addr+++genV4SubflowAddress :: MptcpAttr -> IPv4 -> (Int, ByteString)+genV4SubflowAddress attr ip = (fromEnum attr, runPut $ putWord32be w32)+ where+ w32 = getIPv4 ip++genV6SubflowAddress :: MptcpAttr -> IPv6 -> (Int, ByteString)+genV6SubflowAddress _addr = undefined++mptcpListToAttributes :: [MptcpAttribute] -> Attributes+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 =+ let+ -- expects a ByteString+ 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+ -- TODO fix sfFamily+ TcpConnection _srcIp _dstIp sport dport prio lid rid (Just intfId)+++-- TODO prefix with 'e' for enum+-- Map.lookup (fromEnum attr) m+-- getAttribute :: MptcpAttr -> Attributes -> Maybe MptcpAttribute+-- getAttribute attr m+-- | attr == MPTCP_ATTR_TOKEN = Nothing+-- | otherwise = Nothing++-- getAttribute :: (Int, ByteString) -> CtrlAttribute+-- getAttribute (i, x) = fromMaybe (CTRL_ATTR_UNKNOWN i x) $makeAttribute i x++-- getW16 :: ByteString -> Maybe Word16+-- getW16 x = e2M (runGet g16 x)++-- getW32 :: ByteString -> Maybe Word32+-- getW32 x = e2M (runGet g32 x)++-- "either2Maybe"+e2M :: Either a b -> Maybe b+e2M (Right x) = Just x+e2M _ = Nothing++convertAttributesIntoMap :: Attributes -> Map.Map MptcpAttr MptcpAttribute+convertAttributesIntoMap attrs = let+ customFn k val = fromJust (makeAttribute k val)+ 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 -> error $ "Could not build attr " ++ show attrType+ Just bytestring -> makeAttribute (fromEnum attrType) bytestring++-- | Builds an MptcpAttribute from+makeAttribute :: Int -- ^ MPTCP_ATTR_TOKEN value+ -> ByteString+ -> Maybe MptcpAttribute+makeAttribute i val =+ case toEnum i of+ MPTCP_ATTR_TOKEN ->+ case readToken val of+ Left err -> error "could not decode"+ Right mptcpToken -> Just $ MptcpAttrToken mptcpToken++ -- 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)+ MPTCP_ATTR_DADDR6 -> SubflowDestAddress <$> fromIPv6 <$> e2M (getIPv6FromByteString val)+ MPTCP_ATTR_SPORT -> SubflowSourcePort <$> port where port = e2M $ runGet getWord16host val+ 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 -> trace ("if_idx: " ++ show val) (+ case runGet getWord32be val of+ Right x -> Just $ SubflowInterface x+ _ -> 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+ MPTCP_ATTR_FLAGS -> trace "makeAttribute ATTR_FLAGS" Nothing+ MPTCP_ATTR_UNSPEC -> undefined+++dumpAttribute :: Int -> ByteString -> String+dumpAttribute attrId value =+ show $ makeAttribute attrId value++checkIfSocketExistsPkt :: Word16 -> [MptcpAttribute] -> MptcpPacket+checkIfSocketExistsPkt fid attributes =+ genMptcpRequest fid MPTCP_CMD_EXIST True attributes++-- https://stackoverflow.com/questions/47861648/a-general-way-of-comparing-constructors-of-two-terms-in-haskell?noredirect=1&lq=1+-- attrToPair ( SubflowSourcePort port) = (fromEnum MPTCP_ATTR_SPORT, runPut $ putWord8 loc)+isAttribute :: MptcpAttribute -- ^ to compare with+ -> MptcpAttribute -- ^to compare to+ -> 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++hasFamily :: [MptcpAttribute] -> Bool+hasFamily = Prelude.any (isAttribute (SubflowFamily eAF_INET))++-- 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+ in+ assert (hasLocAddr attrs) $ genMptcpRequest fid MPTCP_CMD_REMOVE False attrs+++-- pass token ?+subflowAttrs :: TcpConnection -> [MptcpAttribute]+subflowAttrs con = [+ LocalLocatorId $ localId con+ , RemoteLocatorId $ remoteId con+ , 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+ ]++-- |Generate a request to create a new subflow+capCwndPkt :: MptcpSocket -> MptcpConnection+ -> Word32 -- ^Limit to apply to congestion window+ -> TcpConnection -> MptcpPacket+capCwndPkt (MptcpSocket _ fid) mptcpCon limit sf =+ assert (hasFamily attrs) pkt+ where+ oldPkt = genMptcpRequest fid MPTCP_CMD_SND_CLAMP_WINDOW False attrs+ 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+newSubflowPkt :: MptcpSocket -> MptcpConnection -> TcpConnection -> MptcpPacket+newSubflowPkt (MptcpSocket _ fid) mptcpCon sf = let+ _cmd = MPTCP_CMD_SUB_CREATE+ attrs = connectionAttrs mptcpCon ++ subflowAttrs sf+ pkt = genMptcpRequest fid MPTCP_CMD_SUB_CREATE False attrs+ in+ assert (hasFamily attrs) pkt+
+ src/Net/Mptcp/Constants.chs view
@@ -0,0 +1,50 @@+{-# LANGUAGE ForeignFunctionInterface #-}+{-|+Module : Net.Mptcp.Constants+Description : A module to bridge the haskell code to underlying C code++I consider this module internal.+The documentation may be a bit sparse.+Inspired by:+https://stackoverflow.com/questions/6689969/how-does-one-interface-with-a-c-enum-using-haskell-and-ffi++TODO might be best to just use the netlink script and adapt it+https://github.com/Ongy/netlink-hs/issues/7+-}+module Net.Mptcp.Constants (+ MptcpAttr(..)+ , MptcpGenlEvent(..)++ , mptcpGenlVer+ , mptcpGenlName+ , mptcpGenlCmdGrpName+ , mptcpGenlEvGrpName+)+where++import Data.Word (Word8)+-- import System.Linux.Netlink.Constants (MessageType)+import Data.Bits ()++-- from include/uapi/linux/mptcp.h+#include <linux/mptcp.h>++-- {underscoreToCase}+-- add prefix = "e"+{#enum MPTCP_ATTR_UNSPEC as MptcpAttr {} omit (__MPTCP_ATTR_AFTER_LAST) deriving (Eq, Show, Ord)#}++-- {underscoreToCase}+-- can also be seen as a command+{#enum MPTCP_CMD_UNSPEC as MptcpGenlEvent {} deriving (Eq, Show)#}++-- |Generic netlink MPTCP version+mptcpGenlVer :: Word8+mptcpGenlVer = {#const MPTCP_GENL_VER #}++mptcpGenlName :: String+mptcpGenlName = {#const MPTCP_GENL_NAME #}+mptcpGenlCmdGrpName :: String+mptcpGenlCmdGrpName = {#const MPTCP_GENL_CMD_GRP_NAME #}+mptcpGenlEvGrpName :: String+mptcpGenlEvGrpName = {#const MPTCP_GENL_EV_GRP_NAME #}+
+ src/Net/Mptcp/PathManager.hs view
@@ -0,0 +1,207 @@+{-+Module: Net.Mptcp.PathManager+Description :+Maintainer : matt+Portability : Linux++Trying to come up with a userspace abstraction for MPTCP path management++-}+++module Net.Mptcp.PathManager (+ PathManager (..)+ , NetworkInterface(..)+ , AvailablePaths+ , PathManagerConfig+ , loadConnectionsFromFile+ , mapIPtoInterfaceIdx+ , defaultPathManagerConfig+ -- TODO don't export / move to its own file+ , handleAddr+ , globalInterfaces+) where++import Prelude hiding (concat, init)++import Control.Concurrent+import Data.Aeson+import qualified Data.Map as Map+import Data.Word (Word32)+import Debug.Trace+import Net.IP+import Net.Mptcp+import Net.Tcp+import System.Linux.Netlink as NL+import qualified System.Linux.Netlink.Route as NLR+-- 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 (init, unpack)+import qualified Data.ByteString.Lazy as BL+import Data.Maybe (fromMaybe)+import Net.IPAddress+import System.IO.Unsafe++{-# NOINLINE globalInterfaces #-}+globalInterfaces :: MVar AvailablePaths+globalInterfaces = unsafePerformIO newEmptyMVar+++data PathManagerConfig = PathManagerConfig {+ pmcIgnoreInterfaces :: [String]+}++defaultPathManagerConfig :: PathManagerConfig+defaultPathManagerConfig = PathManagerConfig {+ pmcIgnoreInterfaces = interfacesToIgnore+}++interfacesToIgnore :: [String]+interfacesToIgnore = [+ "virbr0"+ , "virbr1"+ , "nlmon0"+ , "ppp0"+ , "lo"+ ]++-- basically a retranscription of NLR.NAddrMsg+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++-- | Load a list of connections from a json file+loadConnectionsFromFile :: FilePath -> IO [TcpConnection]+loadConnectionsFromFile filename = do+ -- Log.info ("Loading connections whitelist from " <> tshow filename <> "...")+ filteredConnectionsStr <- BL.readFile filename+ case Data.Aeson.eitherDecode filteredConnectionsStr of+ Left errMsg -> error ("Failed loading " ++ filename ++ ":\n" ++ errMsg)+ Right list -> return list+++-- |Reimplements+-- TODO we should not need the socket+-- onMasterEstablishement+data PathManager = PathManager {+ name :: String+ -- interfacesToIgnore :: [String]+ , onMasterEstablishement :: MptcpSocket -> MptcpConnection -> AvailablePaths -> [MptcpPacket]+}++-- } deriving PathManager+++handleInterfaceNotification+ :: AddressFamily -> Attributes -> Word32 -> Maybe NetworkInterface+handleInterfaceNotification addrFamily attrs addrIntf =++ -- 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+ -- 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 :: PathManagerConfig -> 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 cfg (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 })
+ src/Net/Mptcp/PathManager/Default.hs view
@@ -0,0 +1,79 @@+{-|+Description : Implementation of mptcp netlink path manager+module: Net.Mptcp.PathManager.Default+Maintainer : matt+Portability : Linux+-}+module Net.Mptcp.PathManager.Default (+ -- TODO don't export / move to its own file+ ndiffports+ , meshPathManager+) where++import Data.Maybe (fromJust)+import qualified Data.Set as Set+import Debug.Trace+import Net.Mptcp+import Net.Mptcp.PathManager+import Net.Tcp++-- | Opens several subflows on each interface+ndiffports :: PathManager+ndiffports = PathManager {+ name = "ndiffports"+ , onMasterEstablishement = nportsOnMasterEstablishement+}++-- | Creates a subflow between each pair of (client, server) interfaces+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+
+ src/Net/SockDiag.hs view
@@ -0,0 +1,524 @@+{-|+Module : Net.SockDiag+Description : Implementation of mptcp netlink path manager+Maintainer : matt+Stability : testing+Portability : Linux++-}+{-# LANGUAGE DeriveAnyClass #-}+{-# LANGUAGE DeriveGeneric #-}+module Net.SockDiag (+ SockDiagMsg (..)+ , SockDiagExtension (..)+ , genQueryPacket+ , loadExtension+ , showExtension+ , connectionFromDiag+ -- WARN dont use it will be removed+ , enumsToWord+) where++-- import Generated+import Data.Word (Word16, Word32, Word64, Word8)++import Prelude hiding (concat, init, length)++import Data.Either (fromRight)+import Data.Maybe (fromJust)++import Data.Serialize+import Data.Serialize.Get ()+import Data.Serialize.Put ()++-- import Control.Monad (replicateM)++import System.Linux.Netlink+import System.Linux.Netlink.Constants++import Data.Bits ((.|.))+import qualified Data.Bits as B+import Data.ByteString (ByteString, pack)+import Data.ByteString.Char8 as C8 (init, unpack)+import qualified Data.Map as Map+import Net.IP ()+import Net.IPAddress+-- import Net.IPv4+import Net.SockDiag.Constants+import Net.Tcp++--+-- 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+++-- TODO provide constructor from Cookie+-- and one fronConnection+-- {| InetDiagFromCookie Word64+--+-- |}+data InetDiagSockId = InetDiagSockId {+ 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];+ -- __be32 idiag_dst[4];+ -- we don't know yet the address family+ , idiag_src :: ByteString+ , idiag_dst :: ByteString++ , idiag_intf :: Word32 -- ^Interface id+ , idiag_cookie :: Word64 -- ^To specifically request an sockid++} deriving (Eq, Show, Generic)++{-# OPTIONS_GHC -Wno-incomplete-patterns #-}+++-- TODO we need a way to rebuild from the integer to the enum+class Enum2Bits a where+ -- toBits :: [a] -> Word32+ shiftL :: a -> Word32++instance Enum2Bits TcpState where+ shiftL state = B.shiftL 1 (fromEnum state)++instance Enum2Bits SockDiagExtensionId where+ shiftL state = B.shiftL 1 (fromEnum state - 1)++++enumsToWord :: Enum2Bits a => [a] -> Word32+enumsToWord [] = 0+enumsToWord (x:xs) = (shiftL x) .|. (enumsToWord xs)++-- TODO use bitset package ? but broken+wordToEnums :: Enum2Bits a => Word32 -> [a]+wordToEnums _ = []++{- | 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+ , idiag_expires :: Word32+ , idiag_rqueue :: Word32+ , idiag_wqueue :: Word32+ , idiag_uid :: Word32+ , idiag_inode :: Word32+} deriving (Eq, Show, Generic)++{-# LANGUAGE FlexibleInstances #-}++-- TODO this generates the error "Orphan instance: instance Convertable [TcpState]"+-- instance Convertable [TcpState] where+-- getPut = putStates+-- getGet _ = return []++putStates :: [TcpState] -> Put+putStates states = putWord32host $ enumsToWord states+++instance Convertable SockDiagMsg where+ getPut = putSockDiagMsg+ getGet _ = getSockDiagMsg++-- TODO rename to a TCP one ? SockDiagRequest+data SockDiagRequest = SockDiagRequest {+ sdiag_family :: Word8 -- ^AF_INET6 or AF_INET (TODO rename)+-- 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+ -- 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+ , idiag_states :: [TcpState] -- ^States to dump (based on TcpDump) Word32+ , diag_sockid :: InetDiagSockId -- ^inet_diag_sockid+} deriving (Eq, Show)++{- |Typeclase used by the system. Basically 'Storable' for 'Get' and 'Put'+getGet Returns a 'Get' function for the convertable.+The MessageType is passed so that the function can parse different data structures+based on the message type.+-}+-- class Convertable a where+-- getGet :: MessageType -> Get a -- ^get a 'Get' function for the static data+-- getPut :: a -> Put -- ^get a 'Put' function for the static data+instance Convertable SockDiagRequest where+ getPut = putSockDiagRequestHeader+ -- MessageType+ getGet _ = getSockDiagRequestHeader++-- |'Get' function for 'GenlHeader'+-- applicative style Trade <$> getWord32le <*> getWord32le <*> getWord16le+getSockDiagRequestHeader :: Get SockDiagRequest+getSockDiagRequestHeader = do+ addressFamily <- getWord8 -- AF_INET for instance+ protocol <- getWord8+ extended <- getWord32host+ _pad <- getWord8+ -- TODO discarded later+ states <- getWord32host+ _sockid <- getInetDiagSockid+ -- TODO reestablish states+ return $ SockDiagRequest addressFamily protocol+ (wordToEnums extended :: [SockDiagExtensionId]) (wordToEnums states :: [TcpState]) _sockid++-- |'Put' function for 'GenlHeader'+putSockDiagRequestHeader :: SockDiagRequest -> Put+putSockDiagRequestHeader request = do+ -- let states = enumsToWord $ idiag_states request+ putWord8 $ sdiag_family request+ putWord8 $ sdiag_protocol request+ -- extended todo use Enum2Bits+ --putWord32host $ enumsToWord states+ putWord8 ( fromIntegral (enumsToWord $ idiag_ext request) :: Word8)+ putWord8 0 -- padding ?+ -- TODO check endianness+ 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 for srcIp") (getIPFromByteString (idiag_family msg) (idiag_src sockid))+ , dstIp = fromRight (error "no default for destIp") (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 ?+getSockDiagMsg :: Get SockDiagMsg+getSockDiagMsg = do+ family <- getWord8+ state <- getWord8+ timer <- getWord8+ retrans <- getWord8++ _sockid <- getInetDiagSockid+ expires <- getWord32host+ rqueue <- getWord32host+ wqueue <- getWord32host+ uid <- getWord32host+ inode <- getWord32host+ return$ SockDiagMsg (fromIntegral family) state timer retrans _sockid expires rqueue wqueue uid inode++putSockDiagMsg :: SockDiagMsg -> Put+putSockDiagMsg msg = do+ putWord8 $ fromIntegral $ fromEnum $ idiag_family msg+ putWord8 $ idiag_state msg+ putWord8 $ idiag_timer msg+ putWord8 $ idiag_retrans msg++ putInetDiagSockid $ idiag_sockid msg++ -- Network order+ putWord32le $ idiag_expires msg+ putWord32le $ idiag_rqueue msg+ putWord32le $ idiag_wqueue msg+ putWord32le $ idiag_uid msg+ putWord32le $ idiag_inode msg++-- TODO add support for OWDs+getInetDiagSockid :: Get InetDiagSockId+getInetDiagSockid = do+ sport <- getWord16host+ dport <- getWord16host+ -- iterate/ grow+ _src <- getByteString (4*4)+ _dst <- getByteString (4*4)+ _intf <- getWord32host+ 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+ putWord16be $ idiag_sport cust+ putWord16be $ idiag_dport cust+ putByteString (idiag_src cust)+ putByteString (idiag_dst cust)+ putWord32host $ idiag_intf cust+ putWord64host $ idiag_cookie cust+++getDiagVegasInfo :: Get SockDiagExtension+getDiagVegasInfo =+ TcpVegasInfo <$> getWord32host <*> getWord32host <*> getWord32host <*> getWord32host++-- TODO generate via FFI ?+eIPPROTO_TCP :: Word8+eIPPROTO_TCP = 6+++{-|+Different answers described in include/uapi/linux/inet_diag.h+Please keep the spacing the same as+-}+data SockDiagExtension =+ -- | Exact copy of kernel's struct tcp_info+ -- tcp_diag_get_info+ DiagTcpInfo {+ tcpi_state :: Word8,+ tcpi_ca_state :: Word8,+ tcpi_retransmits :: Word8,+ tcpi_probes :: Word8,+ tcpi_backoff :: Word8,+ tcpi_options :: Word8,+ tcpi_wscales :: Word8 -- ^both sender and receiver on 4 bits+ , tcpi_delivery_rate_app_limited :: Word8 -- ^but only first bit used++ , tcpi_rto :: Word32,+ tcpi_ato :: Word32,+ tcpi_snd_mss :: Word32,+ tcpi_rcv_mss :: Word32,++ tcpi_unacked :: Word32,+ tcpi_sacked :: Word32,+ tcpi_lost :: Word32,+ tcpi_retrans :: Word32,+ tcpi_fackets :: Word32,++ -- Time+ tcpi_last_data_sent :: Word32,+ tcpi_last_ack_sent :: Word32,+ tcpi_last_data_recv :: Word32,+ tcpi_last_ack_recv :: Word32,++ -- Metric+ tcpi_pmtu :: Word32,+ tcpi_rcv_ssthresh :: Word32,+ tcpi_rtt :: Word32,+ tcpi_rttvar :: Word32,+ tcpi_snd_ssthresh :: Word32,+ tcpi_snd_cwnd :: Word32,+ tcpi_advmss :: Word32,+ tcpi_reordering :: Word32,++ tcpi_rcv_rtt :: Word32,+ tcpi_rcv_space :: Word32++ , tcpi_total_retrans :: Word32++ , tcpi_pacing_rate :: Word64+ , tcpi_max_pacing_rate :: Word64+ , tcpi_bytes_acked :: Word64+ , tcpi_bytes_received :: Word64+ , tcpi_segs_out :: Word32+ , tcpi_segs_in :: Word32++ , tcpi_notsent_bytes :: Word32+ , tcpi_min_rtt :: Word32+ , tcpi_data_segs_in :: Word32+ , tcpi_data_segs_out :: Word32++ , tcpi_delivery_rate :: Word64++ , tcpi_busy_time :: Word64+ , tcpi_rwnd_limited :: Word64+ , tcpi_sndbuf_limited :: Word64++ , tcpi_delivered :: Word32+ , tcpi_delivered_ce :: Word32++ , tcpi_bytes_sent :: Word64+ , tcpi_bytes_retrans :: Word64+ , tcpi_dsack_dups :: Word32+ , tcpi_reord_seen :: Word32++ -- Extended version, hoping it doesn't break too much stuff+ , tcpi_snd_cwnd_clamp :: Word32+ , tcpi_fowd :: Word32+ , tcpi_bowd :: Word32++} | DiagExtensionMemInfo {+ idiag_rmem :: Word32 -- ^ Amount of data in the receive queue.+, idiag_wmem :: Word32 -- ^ amount of data that is queued by TCP but not yet sent.+, idiag_fmem :: Word32 -- ^ amount of memory scheduled for future use+, idiag_tmem :: Word32 -- ^ amount of data in send queue.+} |+ -- | Not exclusive to Vegas unlike the name indicates, mirrors tcpvegas_info+ TcpVegasInfo {+ tcpInfoVegasEnabled :: Word32+ , tcpInfoRttCount :: Word32+ , tcpInfoRtt :: Word32+ , tcpInfoMinrtt :: Word32+} | CongInfo String+ | SockDiagShutdown Word8+ -- Apparently used to pass BBR data+ | SockDiagMark Word32+ deriving (Show, Generic)++-- ideally we should be able to , Serialize+-- instance Convertable SockDiagExtension where+-- getGet _ = get+-- getPut = put+++getTcpVegasInfo :: Get SockDiagExtension+getTcpVegasInfo = TcpVegasInfo <$> getWord32host <*> getWord32host <*> getWord32host <*> getWord32host++getMemInfo :: Get SockDiagExtension+getMemInfo = DiagExtensionMemInfo <$> getWord32host <*> getWord32host <*> getWord32host <*> getWord32host++getDiagMark :: Get SockDiagExtension+getDiagMark = SockDiagMark <$> getWord32host+++getShutdown :: Get SockDiagExtension+getShutdown = SockDiagShutdown <$> getWord8++-- | Get congestion control name+getCongInfo :: Get SockDiagExtension+getCongInfo = do+ left <- remaining+ bs <- getByteString left+ return (CongInfo $ unpack $ init bs)+++getDiagTcpInfo :: Get SockDiagExtension+getDiagTcpInfo = DiagTcpInfo <$> getWord8 <*> getWord8 <*> getWord8 <*> getWord8 <*> getWord8 <*> getWord8 <*> getWord8 <*> getWord8+ <*> getWord32host <*> getWord32host <*> getWord32host <*> getWord32host+ <*> getWord32host <*> getWord32host <*> getWord32host <*> getWord32host <*> getWord32host+ -- times+ <*> getWord32host <*> getWord32host <*> getWord32host <*> getWord32host+ -- metrics+ <*> getWord32host <*> getWord32host <*> getWord32host <*> getWord32host+ <*> getWord32host <*> getWord32host <*> getWord32host <*> getWord32host+++ <*> getWord32host <*> getWord32host++ -- tcpi_total_retrans+ <*> getWord32host++ -- starts at tcpi_pacing_rate+ <*> getWord64host <*> getWord64host <*> getWord64host <*> getWord64host+ <*> getWord32host <*> getWord32host++ -- starts at tcpi_notsent_bytes+ <*> getWord32host <*> getWord32host <*> getWord32host <*> getWord32host++ -- tpci_delivery_rate+ <*> getWord64host++ <*> getWord64host <*> getWord64host<*> getWord64host++ -- tcpi_delivered+ <*> getWord32host <*> getWord32host++ -- tcpi_bytes_sent+ <*> getWord64host<*> getWord64host <*> getWord32host <*> getWord32host++ -- My custom addition to read the owds, it's an extra that should be removed+ -- for a vanilla kernel+ <*> getWord32host <*> getWord32host <*> getWord32host++-- Sends a SockDiagRequest+-- expects INetDiag+-- TODO should take an Mptcp connection into account+-- We should use cookies later on+-- MaybeCookie ?+-- TcpConnection -- ^Connection we are requesting+-- #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)))+-- stateFilter = [TcpListen, TcpEstablished, TcpSynSent ]++-- InetDiagInfo+-- TODO we need to request more !+-- TODO if we have a cookie ignore the rest ?!+-- requestedInfo = InetDiagNone++showExtension :: SockDiagExtension -> String+showExtension (CongInfo cc) = "Using CC " ++ (show cc)+showExtension (TcpVegasInfo _ _ rtt minRtt) = "RTT=" ++ (show rtt) ++ " minRTT=" ++ show minRtt+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++{- 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++ diag_req = case selector of+ -- TODO+ Left cookie -> let+ bstr = pack $ replicate 128 (0 :: Word8)+ in+ InetDiagSockId 0 0 bstr bstr 0 cookie++ Right con -> let+ ipSrc = runPut $ putIPAddress (srcIp con)+ ipDst = runPut $ putIPAddress (dstIp con)+ ifIndex = subflowInterface con+ _cookie = 0 :: Word64+ in+ InetDiagSockId (srcPort con) (dstPort con) ipSrc ipDst (fromJust ifIndex) _cookie++ custom = SockDiagRequest eAF_INET eIPPROTO_TCP requestedInfo tcpStatesFilter diag_req+ in+ Packet hdr custom Map.empty++-- | to search for a specific connection+queryPacketFromCookie :: Word64 -> Packet SockDiagRequest+queryPacketFromCookie cookie = genQueryPacket (Left cookie) [] []+++loadExtension :: Int -> ByteString -> Maybe SockDiagExtension+loadExtension key value = let+ eExtId = (toEnum key :: SockDiagExtensionId)+ fn = case toEnum key of+ -- MessageType shouldn't matter anyway ?!+ InetDiagCong -> Just getCongInfo+ -- InetDiagNone -> Nothing+ InetDiagInfo -> Just getDiagTcpInfo+ InetDiagVegasinfo -> Just getTcpVegasInfo+ InetDiagShutdown -> Just getShutdown+ InetDiagMeminfo -> Just getMemInfo+ -- requires CAP_NET_ADMIN+ InetDiagMark -> Just getDiagMark+ _ -> Nothing+ -- _ -> case decode value of+ -- Right x -> Just x+ -- -- Left err -> error $ "fourre-tout error " ++ err+ -- Left err -> Nothing++ in case fn of+ Nothing -> Nothing+ Just getFn -> case runGet getFn value of+ Right x -> Just $ x+ Left err -> error $ "error decoding " ++ show eExtId ++ ":\n" ++ err+
+ src/Net/SockDiag/Constants.chs view
@@ -0,0 +1,37 @@+{-# LANGUAGE ForeignFunctionInterface #-}+{-|+Module : Net.SockDiag.Constants+Description : A module to bridge the haskell code to underlying C code+Portability : Linux++TODO might be best to just use the netlink script and adapt it+https://github.com/Ongy/netlink-hs/issues/7+-}+module Net.SockDiag.Constants+where++import Data.Word ()+import System.Linux.Netlink.Constants (MessageType)+import Data.Bits ()+++-- from include/uapi/linux/inet_diag.h+#include <linux/inet_diag.h>++-- let it use Bits as well as fNLM_F_REQUEST so that I can chain them with .|.+-- , Bits TODO rename to eDiagExt ?+{#enum INET_DIAG_NONE as SockDiagExtensionId {underscoreToCase} deriving (Eq, Show)#}++#include <linux/sock_diag.h>++msgTypeSockDiag :: MessageType+msgTypeSockDiag = {#const SOCK_DIAG_BY_FAMILY #}+++-- {#enum AF_UNSPEC as eAddressFamily {underscoreToCase} deriving (Eq, Show)#}+-- TODO generate AF_INET (6) from include/linux/socket.h+-- IPPROTO_TCP defined in include/uapi/linux/in.h++-- TODO Convert struct ?+-- inet_diag_req_v2 +
+ src/Net/Tcp.hs view
@@ -0,0 +1,20 @@+{-# OPTIONS_GHC -fno-warn-orphans #-}+{-|+Module : Net.Tcp+Description : Implementation of mptcp netlink path manager+Maintainer : matt+Stability : testing+Portability : Linux++-}+module Net.Tcp (+ module Net.Tcp.Definitions+ , module Net.Tcp.Constants+) where++import Net.Bitset+import Net.Tcp.Constants+import Net.Tcp.Definitions+++instance ToBitMask TcpFlag
+ src/Net/Tcp/Constants.chs view
@@ -0,0 +1,86 @@+{-# LANGUAGE ForeignFunctionInterface #-}+{-|+Module : Net.Mptcp.Constants+Description : A module to bridge the haskell code to underlying C code++I consider this module internal.+The documentation may be a bit sparse.+Inspired by:+https://stackoverflow.com/questions/6689969/how-does-one-interface-with-a-c-enum-using-haskell-and-ffi++TODO might be best to just use the netlink script and adapt it+https://github.com/Ongy/netlink-hs/issues/7+-}+module Net.Tcp.Constants+where++import Data.Bits ()+import Data.Word ()+import GHC.Generics (Generic)++-- copy from include/net/tcp_states since it's not part of the user API+#include <tcp_states.h>++-- For anonymous C enums, we can use , Bits+{#enum TCP_ESTABLISHED as TcpState {underscoreToCase} deriving (Eq, Show)#}++-- tcp_ca_state is a bitfield see+-- http://www.yonch.com/tech/linux-tcp-congestion-control-internals+#include <linux/tcp.h>+++{#enum TCP_CA_Open as TcpCAState {underscoreToCase} deriving (Eq, Show)#}++-- GenBind.evalCCast: Casts are implemented only for integral constants+-- {#enum define TcpFlag {TCP_FLAG_SYN as TcpFlagSyn} deriving (Eq, Show)#}++data TcpFlag = TcpFlagFin | TcpFlagSyn | TcpFlagRst | TcpFlagPsh+ | TcpFlagAck | TcpFlagUrg | TcpFlagEcn | TcpFlagCwr | TcpFlagNonce+ deriving (Eq, Show, Bounded, Generic)++-- values are power of 2 of the flag+instance Enum TcpFlag where+ toEnum 0 = TcpFlagFin+ toEnum 1 = TcpFlagSyn+ toEnum 2 = TcpFlagRst+ toEnum 3 = TcpFlagPsh+ toEnum 4 = TcpFlagAck+ toEnum 5 = TcpFlagUrg+ toEnum 6 = TcpFlagEcn+ toEnum 7 = TcpFlagCwr+ toEnum 8 = TcpFlagNonce+ toEnum n = error $ "toEnum n: " ++ show n++ fromEnum TcpFlagFin = 0+ fromEnum TcpFlagSyn = 1+ fromEnum TcpFlagRst = 2+ fromEnum TcpFlagPsh = 3+ fromEnum TcpFlagAck = 4+ fromEnum TcpFlagUrg = 5+ fromEnum TcpFlagEcn = 6+ fromEnum TcpFlagCwr = 7+ fromEnum TcpFlagNonce = 8+ -- fromEnum _ = error $ "fromEnum not implemented"++ enumFrom x = enumFromTo x maxBound+ enumFromThen x y = enumFromThenTo x y bound+ where+ bound | fromEnum y >= fromEnum x = maxBound+ | otherwise = minBound+++-- TCP_FLAG_CWR = __constant_cpu_to_be32(0x00800000),+-- TCP_FLAG_ECE = __constant_cpu_to_be32(0x00400000),+-- TCP_FLAG_URG = __constant_cpu_to_be32(0x00200000),+-- TCP_FLAG_ACK = __constant_cpu_to_be32(0x00100000),+-- TCP_FLAG_PSH = __constant_cpu_to_be32(0x00080000),+-- TCP_FLAG_RST = __constant_cpu_to_be32(0x00040000),+-- TCP_FLAG_SYN = __constant_cpu_to_be32(0x00020000),+-- TCP_FLAG_FIN = __constant_cpu_to_be32(0x00010000),++-- #define TH_FIN 0x0001+-- #define TH_SYN 0x0002+-- #define TH_RST 0x0004+-- #define TH_PUSH 0x0008+-- #define TH_ACK 0x0010+
+ src/Net/Tcp/Definitions.hs view
@@ -0,0 +1,84 @@+{-|+Module : Net.Tcp.Definitions+Description : Implementation of mptcp netlink path manager+Maintainer : matt+Stability : testing+Portability : Linux++-}+{-# LANGUAGE NoImplicitPrelude #-}+{-# LANGUAGE OverloadedStrings #-}+module Net.Tcp.Definitions (+ TcpConnection (..)+ , ConnectionRole (..)+ , reverseTcpConnection+ , showTcpConnection+)++where++import Data.Aeson+import qualified Data.Text as TS+import Data.Word (Word16, Word32, Word8)+import GHC.Generics+import Net.IP+import Prelude++{- Describe a TCP connection, possibly an Mptcp subflow+ The equality implementation ignores several fields+-}+data TcpConnection = TcpConnection {+ -- TODO use libraries to deal with that ? filter from the command line for instance ?+ srcIp :: IP -- ^Source ip+ , dstIp :: IP -- ^Destination ip+ , srcPort :: Word16 -- ^ Source port+ , dstPort :: Word16 -- ^Destination port+ , priority :: Maybe Word8 -- ^subflow priority+ , localId :: Word8 -- ^ Convert to AddressFamily+ , remoteId :: Word8+ -- TODO remove could be deduced from srcIp / dstIp ?+ , subflowInterface :: Maybe Word32 -- ^Interface of Maybe ? why a maybe ?+ -- add TcpMetrics member+ -- , tcpMetrics :: Maybe [SockDiagExtension] -- ^Metrics retrieved from kernel++} deriving (Show, Generic, Ord)++tshow :: Show a => a -> TS.Text+tshow = TS.pack . Prelude.show++data ConnectionRole = Server | Client deriving (Show, Eq)+++showTcpConnectionText :: TcpConnection -> TS.Text+showTcpConnectionText con =+ showIp ( srcIp con) <> ":" <> tshow (srcPort con) <> " -> " <> showIp (dstIp con) <> ":" <> tshow (dstPort con)+ where+ showIp = Net.IP.encode++showTcpConnection :: TcpConnection -> String+showTcpConnection = TS.unpack . showTcpConnectionText+++reverseTcpConnection :: TcpConnection -> TcpConnection+reverseTcpConnection con = con {+ srcIp = dstIp con+ , dstIp = srcIp con+ , srcPort = dstPort con+ , dstPort = srcPort con+ , priority = Nothing+ , localId = remoteId con+ , remoteId = localId con+ , subflowInterface = Nothing+}++instance FromJSON TcpConnection+instance ToJSON TcpConnection++-- TODO create a specific function for it+-- ignore the rest+instance Eq TcpConnection where+ x == y = srcIp x == srcIp y && dstIp x == dstIp y+ && srcPort x == srcPort y && dstPort x == dstPort y+ -- /= = not ==++
+ src/app/Main.hs view
@@ -0,0 +1,918 @@+{-|+Description : Implementation of mptcp netlink path manager+Maintainer : matt+Stability : testing+Portability : Linux++This userspace program is a complement to the linux MPTCP kernel developed at+https://github.com/multipath-tcp/mptcp++The main daemon monitors MPTCP connections and for each new connection assigns a thread+to mino.+++The daemon main thread has 2 roles:+- monitors interface change (network interface addition/deletion)+- listens to++Monitors new MPTCP connections and runs a specific monitor instance+To interact+GENL_ADMIN_PERM+The operation requires the CAP_NET_ADMIN privilege+iproute2/misc/ss.c to see how `ss` utility interacts with the kernel+++Capture netlink packets in your computer ?+-}+{-# LANGUAGE OverloadedStrings #-}+{-# OPTIONS_GHC -fno-warn-orphans #-}+{-# LANGUAGE DeriveAnyClass #-}+{-# LANGUAGE StandaloneDeriving #-}++module Main where++import Net.IP+import Net.Mptcp+import Net.Mptcp.Constants+import Net.Mptcp.PathManager+import Net.Mptcp.PathManager.Default+import Net.SockDiag+import Net.SockDiag.Constants+import Net.Tcp++import Control.Monad (foldM)+import Control.Monad.Trans (liftIO)+-- import Control.Monad.Trans (liftIO)+import Control.Monad.Trans.State (State, StateT, execStateT, get, put)+import Data.Maybe (catMaybes)+-- import Data.Text (Text)+import Foreign.C.Types (CInt)+import Options.Applicative hiding (ErrorMsg, empty, value)+import qualified Options.Applicative (value)+import Prelude hiding (concat, init, log)+import Text.Read (readMaybe)+-- for eOK, ePERM+import Foreign.C.Error+-- import qualified System.Linux.Netlink as NL+import System.Linux.Netlink as NL+import System.Linux.Netlink.Constants as NLC+import System.Linux.Netlink.GeNetlink as GENL+-- import System.Linux.Netlink.Constants (eRTM_NEWADDR)+-- import System.Linux.Netlink.Helpers+-- import System.Log.FastLogger+import System.Linux.Netlink.GeNetlink.Control+import qualified System.Linux.Netlink.Route as NLR+import qualified System.Linux.Netlink.Simple as NLS++import Data.Word (Word32)+import System.Exit+import System.Process+-- import qualified Data.Bits as Bits -- (shiftL, )+-- import Data.Bits ((.|.))+import Data.Serialize.Get (runGet)+import Data.Serialize.Put+-- import Data.Either (fromRight)+import Control.Concurrent+import Data.Bits (Bits(..))+import Data.ByteString (ByteString)+import qualified Data.ByteString.Lazy as BL+import qualified Data.Map as Map+import qualified Data.Set as Set+import qualified Data.Text as TS+-- import Debug.Trace+import Data.Aeson+import Numeric.Natural+import System.FilePath ()+-- import System.IO (stderr)+import System.IO.Temp ()+-- to merge MptcpConnection export and Metrics+import Data.Aeson.Extra.Merge (lodashMerge)+import GHC.List (init)++import Data.Either (fromRight)+import GHC.Generics (Generic)+import Polysemy+import qualified Polysemy as P+import Polysemy.Log (Log)+import qualified Polysemy.Log as Log+import Polysemy.Log.Colog (interpretLogStdout)+import qualified Polysemy.State as P+import Polysemy.Trace (Trace, trace)+import qualified Polysemy.Trace as P++-- for getEnvDefault, to get TMPDIR value.+-- we could pass it as an argument+-- import System.Environment.Blank(getEnvDefault)++tshow :: Show a => a -> TS.Text+tshow = TS.pack . Prelude.show++-- |Delay between 2 successful loggings+onSuccessSleepingDelayMs :: Natural+onSuccessSleepingDelayMs = 300+++-- | When it couldn't set the correct value+onFailureSleepingDelay :: Natural+onFailureSleepingDelay = 100++-- |the default path manager+pathManager :: PathManager+pathManager = meshPathManager++-- |Helper to pass information across functions+data MyState = MyState {+ -- |Socket+ socket :: MptcpSocket+ -- ThreadId/MVar+ , connections :: Map.Map MptcpToken (ThreadId, MVar MptcpConnection)+ -- |Arguments passed to the program+ , cliArguments :: CLIArguments+ -- |Connections to accept, loaded via cli's --filter+ , filteredConnections :: Maybe [TcpConnection]+}++ -- https://stackoverflow.com/questions/3640120/combine-state-with-io-actions+type GState a = State MyState a++-- 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+++dumpCommand :: MptcpGenlEvent -> String+dumpCommand x = show x ++ " = " ++ show (fromEnum x)++dumpMptcpCommands :: MptcpGenlEvent -> String+dumpMptcpCommands MPTCP_CMD_EXIST = dumpCommand MPTCP_CMD_EXIST+dumpMptcpCommands x = dumpCommand x ++ "\n" ++ dumpMptcpCommands (succ x)+++-- | Arguments expected on startup+data CLIArguments = CLIArguments {++ -- | 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]+ cliOptimizer :: Maybe FilePath++ -- | to filter+ , cliFilter :: Maybe FilePath++ -- | Folder where to log files+ , out :: FilePath++ -- , clientIP :: IPv4+ , cliQuiet :: Bool++ -- Priority+ , logLevel :: Log.Severity+ }+++-- 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"+++sample :: Parser CLIArguments+sample = CLIArguments+ <$> (optional $ strOption+ ( long "optimizer"+ <> short 'p'+ <> help "Path to the userspace program"+ <> metavar "PROGRAM" ))+ <*> (optional $ strOption+ ( long "filter"+ <> help "Path to a json file describing a TCP connection"+ <> metavar "Filter" ))+ <*> strOption+ ( long "out"+ <> short 'o'+ <> help "Where to store the files"+ <> showDefault+ <> Options.Applicative.value "/tmp"+ <> metavar "PROGRAM" )+ <*> switch+ ( long "verbose"+ <> short 'v'+ <> help "Whether to be quiet" )+ <*> option auto+ ( long "log-level"+ <> help "Log level"+ <> showDefault+ <> Options.Applicative.value Log.Info+ <> metavar "LOG_LEVEL"+ )++deriving instance Read Log.Severity++readConnectionRole :: ReadM Log.Severity+readConnectionRole = eitherReader $ \arg -> case reads arg of+ [(a, "")] -> return $ a+ -- [("client", "")] -> return $ RoleClient+ _ -> Left $ "readConnectionRole: cannot parse value `" ++ arg ++ "`"+++opts :: ParserInfo CLIArguments+opts = info (sample <**> helper)+ ( fullDesc+ <> progDesc "MPTCP path manager"+ <> header "Take control of your subflows now !" )++++-- inspired by makeNL80211Socket Create a 'NL80211Socket' this opens a genetlink+-- socket and gets the family id+-- TODO should record the token too+-- TODO should join the group !!+makeMptcpSocket :: IO MptcpSocket+makeMptcpSocket = do+ -- for legacy reasons this opens a route socket+ sock <- GENL.makeSocket+ res <- getFamilyIdS sock mptcpGenlName+ case res of+ Nothing -> error $ "Could not find family " ++ mptcpGenlName+ Just fid -> return (MptcpSocket sock fid)++++makeMetricsSocket :: IO NetlinkSocket+makeMetricsSocket = makeSocketGeneric eNETLINK_SOCK_DIAG+++-- A utility function - threadDelay takes microseconds, which is slightly annoying.+sleepMs :: Natural -> IO()+sleepMs n = threadDelay $ (fromIntegral n :: Int) * 1000+++-- | here we may want to run mptcpnumerics to get some results+updateSubflowMetrics :: NetlinkSocket -> TcpConnection -> IO SockDiagMetrics+updateSubflowMetrics sockMetrics subflow = do+ putStrLn "Updating subflow metrics"+ let queryPkt = genQueryPacket (Right subflow) [TcpListen, TcpEstablished]++ [InetDiagCong, InetDiagInfo, InetDiagMeminfo]+ sendPacket sockMetrics queryPkt++ putStrLn "Sent the TCP SS request"+ putStrLn "Starting inspecting answers"++ answers <- Main.recvMulti sockMetrics+ let metrics_m = inspectIdiagAnswers answers+ -- filter ? keep only valud ones ?+ return $ head (catMaybes metrics_m)++isFlagSet :: Bits a => a -> a -> Bool+isFlagSet f v = (f .&. v) == f++-- Copy/pasted from System.Linux.Netlink+-- |Internal function to receive multiple netlink messages+recvMulti :: (Convertable a, Eq a, Show a) => NetlinkSocket -> IO [Packet a]+recvMulti sock = do+ pkts <- recvOne sock+ if isMulti (first pkts)+ then if isDone (last pkts)+ -- This is fine because first would have complained before+ then return $ init pkts+ else (pkts ++) <$> Main.recvMulti sock+ else return pkts+ where+ isMulti = isFlagSet fNLM_F_MULTI . messageFlags . packetHeader+ isDone = (== eNLMSG_DONE) . messageType . packetHeader+ first (x:_) = x+ first [] = error "Got empty list from recvOne in recvMulti, this shouldn't happen"++{- |+ Starts monitoring a specific MPTCP connection+ Maybe should expect a pathManager instance (and logger+FilePath -- ^Path towards the program to get cwnd limits+-}+startMonitorConnection ::+ (Members '[Log, P.Trace, Embed IO ] r) =>+ CLIArguments+ -- | elapsed time since starting the thread (very coarse approximation)+ -> Natural+ -> MptcpSocket+ -> NetlinkSocket+ -> MVar MptcpConnection -> Sem r ()+startMonitorConnection cliArgs elapsed mptcpSock sockMetrics mConn = do+ let (MptcpSocket sock _) = mptcpSock+ myId <- embed $ myThreadId+ trace $ show myId ++ ": monitoring connection at *time* " ++ show elapsed ++ " ..."+ -- as long as conn is not empty we keep going ?+ -- for this connection+ -- query metrics for the whole MPTCP connection+ mptcpConn <- embed $ readMVar mConn+ Log.trace "Showing MPTCP connection"+ Log.trace $ tshow mptcpConn <> "..."+ let _token = connectionToken mptcpConn+ let tmpdir = out cliArgs++ -- TODO this is the issue+ -- not sure it's the master with a set+ let _masterSf = Set.elemAt 0 (subflows mptcpConn)++ -- Get updated metrics+ lastMetrics <- embed $ mapM (updateSubflowMetrics sockMetrics) (Set.toList $ subflows mptcpConn)+ let filename = tmpdir ++ "/" ++ "mptcp_" ++ show (connectionToken mptcpConn) ++ "_" ++ show elapsed ++ ".json"+ -- logStatistics filename elapsed mptcpConn lastMetrics++ duration <- case cliOptimizer cliArgs of+ Nothing -> return onSuccessSleepingDelayMs+ Just prog -> do++ Log.debug "Calling third party program"++ cwnds_m <- embed $ getCapsForConnection filename prog mptcpConn lastMetrics+ -- rename to waitingTime ? delay+ case cwnds_m of+ Nothing -> do+ Log.error "Couldn't fetch the values"+ return onFailureSleepingDelay+ Just cwnds -> do++ Log.info $ "Requesting to set cwnds..." <> tshow cwnds+ -- TODO fix+ -- KISS for now (capCwndPkt mptcpSock )+ let cwndPackets = map (\(cwnd, sf) -> capCwndPkt mptcpSock mptcpConn cwnd sf) (zip cwnds (Set.toList $ subflows mptcpConn))++ embed $ mapM_ (sendPacket sock) cwndPackets++ return onSuccessSleepingDelayMs+ Log.debug $ "Finished monitoring token. Waiting " <> tshow duration+ embed $ sleepMs duration++ -- call ourself again+ startMonitorConnection cliArgs (elapsed + duration) mptcpSock sockMetrics mConn++++{-+ | 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 -- ^Statistics file+ -> FilePath -- ^Path towards the PM cliOptimizer+ -> MptcpConnection+ -> [SockDiagMetrics]+ -> IO (Maybe [Word32])+getCapsForConnection filename prog mptcpConn metrics = do++ let subflowCount = length $ subflows mptcpConn++ -- Data.ByteString.Lazy.writeFile filename jsonBs++ -- readProcessWithExitCode binary / args / stdin+ (exitCode, stdout, stderrContent) <- readProcessWithExitCode prog [filename, show subflowCount] ""++ -- Info+ 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 -> (readMaybe stdout) :: Maybe [Word32]+ ExitFailure val -> error $ "stdout:" ++ stdout ++ " stderr: " ++ stderrContent+ )+ return values++-- the library contains showAttrs / showNLAttrs+showAttributes :: Attributes -> String+showAttributes attrs =+ let+ mapped = Map.foldrWithKey (\k v -> (dumpAttribute k v ++) ) "\n " attrs+ in+ mapped++putW32 :: Word32 -> ByteString+putW32 x = runPut (putWord32host x)+++-- I want to override the GenlHeader version+newtype GenlHeaderMptcp = GenlHeaderMptcp GenlHeader+instance Show GenlHeaderMptcp where+ show (GenlHeaderMptcp (GenlHeader cmd ver)) =+ "Header: Cmd = " ++ show cmd ++ ", Version: " ++ show ver ++ "\n"++--+inspectAnswers :: [GenlPacket NoData] -> IO ()+inspectAnswers packets = do+ mapM_ inspectAnswer packets++-- showPacketCustom :: GenlPacket NoData -> String+-- showPacketCustom pkt = let+-- hdr = (genlDataHeader pkt )+-- in showPacket pkt++showHeaderCustom :: GenlHeader -> String+showHeaderCustom = show++inspectAnswer :: GenlPacket NoData -> IO ()+inspectAnswer (Packet _ (GenlData hdr NoData) attributes) = let+ cmd = genlCmd hdr+ in+ putStrLn $ show ("Inspecting answer custom:\n" ++ showHeaderCustom hdr+ ++ "Supposing it's a mptcp command: " ++ dumpCommand ( toEnum $ fromIntegral cmd))++inspectAnswer pkt = putStrLn $ "Inspecting answer:\n" ++ showPacket pkt+++-- should have this running in parallel+queryAddrs :: NLR.RoutePacket+queryAddrs = NL.Packet+ (NL.Header NLC.eRTM_GETADDR (NLC.fNLM_F_ROOT .|. NLC.fNLM_F_MATCH .|. NLC.fNLM_F_REQUEST) 0 0)+ (NLR.NAddrMsg 0 0 0 0 0)+ mempty+++-- |Deal with events for already registered connections+-- Warn: MPTCP_EVENT_ESTABLISHED registers a "null" interface+-- or a list of packets to send+++-- TODO maybe the path manager should be part of the MptcpConnection+dispatchPacketForKnownConnection :: MptcpSocket+ -> MptcpConnection+ -> MptcpGenlEvent+ -> Attributes+ -> AvailablePaths+ -> (Maybe MptcpConnection, [MptcpPacket])+dispatchPacketForKnownConnection mptcpSock con event attributes availablePaths = let+ token = connectionToken con+ subflow = subflowFromAttributes attributes+ in+ case event of++ -- 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)++ -- TODO trigger the pathManager again, fix the remote interpretation+ MPTCP_EVENT_ANNOUNCED -> let+ -- what if it's local+ remId = remoteIdFromAttributes attributes+ -- newConn = mptcpConnAddRemoteId con remId+ newConn = con+ in+ (Just newConn, [])++ MPTCP_EVENT_CLOSED -> (Nothing, [])++ MPTCP_EVENT_SUB_ESTABLISHED -> let+ newCon = mptcpConnAddSubflow con subflow+ in+ (Just newCon,[])+ -- let newState = oldState+ -- putMVar con newCon+ -- let newState = oldState { connections = Map.insert token newCon (connections oldState) }+ -- TODO we should insert the+ -- newConn <-+ -- return newState++ -- TODO remove+ MPTCP_EVENT_SUB_CLOSED -> let+ newCon = mptcpConnRemoveSubflow con subflow+ in+ (Just newCon, [])++ -- MPTCP_CMD_EXIST -> con+ _ -> error $ "should not happen " ++ show event+++-- |Filter connections+-- This should be configurable in some way+acceptConnection :: TcpConnection -> Maybe [TcpConnection] -> Bool+acceptConnection subflow mFilteredConnections =+ case mFilteredConnections of+ Nothing -> True+ -- or notElem+ Just filtered -> subflow `elem` filtered++-- |+mapSubflowToInterfaceIdx :: IP -> IO (Maybe Word32)+mapSubflowToInterfaceIdx ip = do++ res <- tryReadMVar globalInterfaces+ case res of+ Nothing -> error "Couldn't access the list of interfaces"+ Just interfaces -> return $ mapIPtoInterfaceIdx interfaces ip++++registerMptcpConnection :: MptcpToken -> TcpConnection -> StateT MyState IO ()+registerMptcpConnection token subflow = (do+ oldState <- get+ let (MyState mptcpSock conns cliArgs filtered) = oldState+ if acceptConnection subflow filtered == False+ then do+ -- infoM "main" $ "filtered out connection:" ++ show subflow+ return ()+ else (do+ -- putStrLn $ "accepted connection :" ++ show subflow+ -- should we add the subflow yet ? it doesn't have the correct interface idx+ mappedInterface <- liftIO $ mapSubflowToInterfaceIdx (srcIp subflow)+ let fixedSubflow = subflow { subflowInterface = mappedInterface }+ -- let newMptcpConn = (MptcpConnection token [] Set.empty Set.empty)+ let newMptcpConn = mptcpConnAddSubflow (+ MptcpConnection token Set.empty Set.empty Set.empty (cliOptimizer cliArgs)+ ) fixedSubflow++ newConn <- liftIO $ newMVar newMptcpConn+ -- putStrLn $ "Connection established !!\n"++ -- create a new+ sockMetrics <- liftIO $ makeMetricsSocket+ -- start monitoring connection+ -- let threadId = undefined+ threadId <- liftIO $ forkOS (+ -- -- runLogAction @IO (contramap message logTextStdout) $ interpretDataLogColog @Message $ progData+ runM $ P.traceToStdout $ interpretLogStdout$+ startMonitorConnection cliArgs 0 mptcpSock sockMetrics newConn+ )++ -- putStrLn $ "Inserting new MVar "+ put (oldState {+ connections = Map.insert token (threadId, newConn) (connections oldState)+ })+ ))++-- |Treat MPTCP events depending on if the connection is known or not+dispatchPacket :: MyState -> MptcpPacket -> IO MyState+dispatchPacket oldState (Packet hdr (GenlData genlHeader NoData) attributes) = let+ cmd = toEnum $ fromIntegral $ genlCmd genlHeader+ (MyState mptcpSock conns _ _) = oldState+ (MptcpSocket mptcpSockRaw fid) = mptcpSock++ -- i suppose token is always available right ?+ token :: MptcpToken+ token = case Map.lookup (fromEnum MPTCP_ATTR_TOKEN) attributes of+ Nothing -> error "Could not retreive token "+ Just bstr -> fromRight (error "could not retreive token") (readToken bstr)+ maybeMatch = Map.lookup token (connections oldState)+ in do+ putStrLn "Fetching available paths"+ availablePaths <- readMVar globalInterfaces++ putStrLn $ "dispatch cmd " ++ show cmd ++ " for token " ++ show token++ case maybeMatch of+ -- Unknown token+ Nothing -> do++ 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+ execStateT (registerMptcpConnection token subflow) oldState+ _ -> return oldState++ Just (threadId, mvarConn) -> do+ putStrLn "MATT: Received request for a known connection "+ mptcpConn <- takeMVar mvarConn++ 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) }++ (Just newConn, pkts) -> do+ putStrLn "putting mVar"+ putMVar mvarConn newConn+ -- TODO update state++ putStrLn "List of requests made on new master:"+ mapM_ (\pkt -> sendPacket mptcpSockRaw pkt) pkts+ 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+ 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) =+ putStrLn $ "Error msg of type " ++ showErrCode errCode ++ " Packet content:\n"+showError _ = error "Not the good overload"++-- netlink must contain sthg for it+-- /usr/include/asm/errno.h+showErrCode :: CInt -> String+showErrCode err+ | Errno err == ePERM = "EPERM"+ | Errno err == eOK = "EOK"+ | otherwise = show err++-- showErrCode err = case err of+-- -- show err+-- ePERM -> "EPERM"+-- eNOTCONN -> "NOT connected"++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 :: Members '[+-- Log, P.Trace, P.State MyState, P.Embed IO+-- ] r => Sem r ()+doDumpLoop myState = do+ let (MptcpSocket simpleSock fid) = socket myState+ results <- recvOne' simpleSock :: IO [Either String MptcpPacket]+ -- TODO retrieve packets+ -- here we should update the state according+ -- mapM_ (inspectResult myState) results+ -- (Foldable t, Monad m) => (b -> a -> m b) -> b -> t a -> m b+ modifiedState <- foldM inspectResult myState results+ doDumpLoop modifiedState+++-- TODO use polysemy State / log / trace++listenToEvents :: Members '[+ Log, P.Trace, P.State MyState, P.Embed IO+ ] r+ => CtrlAttrMcastGroup+ -> Sem r ()+listenToEvents my_group = do+ myState <- P.get+ let (MptcpSocket sock fid) = socket myState++ embed $ joinMulticastGroup sock (grpId my_group)+ trace $ "Joined grp " ++ grpName my_group+ _ <- P.embed $ doDumpLoop myState+ trace "end of listenToEvents"+++-- testing+listenToMetricEvents :: NetlinkSocket -> CtrlAttrMcastGroup -> IO ()+listenToMetricEvents sock myGroup = do+ putStrLn "listening to metric events"+ joinMulticastGroup sock (grpId myGroup)+ putStrLn $ "Joined grp " ++ grpName myGroup+ -- _ <- doDumpLoop globalState+ -- putStrLn "TOTO"+ -- where+ -- -- mptcpSocket = MptcpSocket sock fid+ -- globalState = MyState mptcpSocket Map.empty+++dumpExtensionAttribute :: Int -> ByteString -> SockDiagExtension+dumpExtensionAttribute attrId value = let+ eExtId = (toEnum attrId :: SockDiagExtensionId)+ ext_m = loadExtension attrId value+ in+ case ext_m of+ Nothing -> error $ "Could not load " ++ show eExtId ++ " (unsupported)\n"+ Just ext -> ext+ -- traceId (show eExtId) ++ " " ++ showExtension ext ++ " \n"++loadExtensionsFromAttributes :: Attributes -> [SockDiagExtension]+loadExtensionsFromAttributes attrs =+ let+ mapped = Map.foldrWithKey (\k v -> ([dumpExtensionAttribute k v] ++ )) [] attrs+ in+ mapped+++{- Parses the requested informations+-}+inspectIDiagAnswer :: Packet SockDiagMsg -> Maybe SockDiagMetrics+inspectIDiagAnswer (Packet hdr cus attrs) =+ Just $ SockDiagMetrics cus (loadExtensionsFromAttributes attrs)+ -- Just cus+inspectIDiagAnswer p = Nothing++-- inspectIDiagAnswer (DoneMsg err) = putStrLn "DONE MSG"+-- (GenlData NoData)+-- inspectIdiagAnswer (Packet hdr (GenlData ghdr NoData) attributes) = putStrLn $ "Inspecting answer:\n"+-- inspectIdiagAnswer (Packet _ (GenlData hdr NoData) attributes) = let+-- cmd = genlCmd hdr+-- in+-- putStrLn $ "Inspecting answer custom:\n" ++ showHeaderCustom hdr+-- ++ "Supposing it's a mptcp command: " ++ dumpCommand ( toEnum $ fromIntegral cmd)+++-- |Convenience wrapper+data SockDiagMetrics = SockDiagMetrics {+ sockDiagMsg :: SockDiagMsg+ -- subflowSubflow :: TcpConnection+ , sockdiagMetrics :: [SockDiagExtension]+} deriving Generic++-- type SockDiagExtension2 = SockDiagExtension+instance ToJSON SockDiagExtension where+ toJSON (tcpInfo@DiagTcpInfo {} ) = let+ -- rtt = tcpi_rtt tcpInfo+ tcpState = toEnum $ fromIntegral ( tcpi_state tcpInfo) :: TcpState+ -- TODO could log ca_state ?++ in+ object [+ "rttvar" .= tcpi_rttvar tcpInfo+ , "rtt_us" .= tcpi_rtt tcpInfo+ , "rto_us" .= tcpi_rto tcpInfo+ , "snd_cwnd" .= tcpi_snd_cwnd tcpInfo+ , "snd_cwnd_clamp" .= tcpi_snd_cwnd_clamp tcpInfo+ , "snd_ssthresh" .= tcpi_snd_ssthresh tcpInfo+ , "reordering" .= tcpi_reordering tcpInfo+ , "tcp_state" .= show tcpState+ , "pacing" .= tcpi_pacing_rate tcpInfo+ , "delivery_rate" .= tcpi_delivery_rate tcpInfo+ , "app_limited" .= tcpi_delivery_rate_app_limited tcpInfo+ -- there is also a delivered_ce ?+ , "delivered" .= tcpi_delivered tcpInfo+ , "lost" .= tcpi_lost tcpInfo+ , "retrans" .= tcpi_retrans tcpInfo+ , "min_rtt" .= tcpi_min_rtt tcpInfo+ , "mtu" .= tcpi_pmtu tcpInfo+ -- TODO try converting it to str+ , "ca_state" .= tcpi_ca_state tcpInfo++ -- bytes_sent+ -- needs kernel patching+ -- , "fowd" .= toJSON ( (fromIntegral rtt/2) :: Float)+ -- , "bowd" .= toJSON ( (fromIntegral rtt/2) :: Float)++ , "fowd" .= tcpi_fowd tcpInfo+ , "bowd" .= tcpi_bowd tcpInfo+++ -- , "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 []+++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+ initialValue = object [+ "srcIp" .= toJSON (srcIp sf)+ , "dstIp" .= toJSON (dstIp sf)+ , "srcPort" .= toJSON (srcPort sf)+ , "dstPort" .= toJSON (dstPort sf)+ -- doesnt work as subflow id+ -- , "subflow_id" .= idiag_uid msg+ ]+ fn x y = lodashMerge (toJSON x) y++ 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 defaultPathManagerConfig . runGet getGenPacket)+ NLS.nlPostMessage routingSock queryAddrs cb+ NLS.nlWaitCurrent routingSock+ dumpSystemInterfaces+++-- | Remove ?+inspectIdiagAnswers :: [Packet SockDiagMsg] -> [Maybe SockDiagMetrics]+inspectIdiagAnswers packets =+ map inspectIDiagAnswer packets+++main :: IO ()+main = do++ -- SETUP LOGGING (https://gist.github.com/ijt/1052896)+ -- streamHandler vs verboseStreamHandler+ -- myStreamHandler <- verboseStreamHandler stderr INFO++ options <- execParser opts+ -- mptcpSocket <- makeMptcpSocket+ -- let (MptcpSocket sock fid) = mptcpSocket++ _ <- runM $ P.traceToStdout $ interpretLogStdout $ program options+ putStrLn "finished"++program :: (Members '[Log, Trace, Embed IO] r) => CLIArguments -> Sem r ()+program options = do++ Log.info "Creating MPTCP netlink socket..."++ Log.info "Now Tracking system interfaces..."+ embed $ putMVar globalInterfaces Map.empty+ routeNl <- embed $ forkIO trackSystemInterfaces++ Log.debug "socket created. MPTCP Family id "++ mptcpSocket <- embed makeMptcpSocket+ let (MptcpSocket sock fid) = mptcpSocket+ mcastMptcpGroups <- embed $ getMulticastGroups sock fid+ -- TODO Log.debug+ embed $ mapM_ Prelude.print mcastMptcpGroups+++ -- use fmap instead+ filteredConns <- case Main.cliFilter options of+ Nothing -> return Nothing+ Just filename -> do+ Log.info ("Loading connections whitelist from " <> tshow filename <> "...")+ filteredConnectionsStr <- embed $ BL.readFile filename+ case Data.Aeson.eitherDecode filteredConnectionsStr of+ Left errMsg -> error ("Failed loading " ++ filename ++ ":\n" ++ errMsg)+ Right list -> return list++ Log.info ("Loading connections whitelisted connections..." <> (tshow filteredConns))++ -- TODO update the state+ let globalState = MyState mptcpSocket Map.empty options filteredConns++ mapM_ (\x -> P.evalState globalState (listenToEvents x)) mcastMptcpGroups+ -- putStrLn $ " Groups: " ++ unwords ( map grpName mcastMptcpGroups )
test/Main.hs view
@@ -4,18 +4,18 @@ -} module Main where -import System.Exit-import Test.HUnit-import Net.SockDiag+import Net.Bitset+import Net.IP import Net.Mptcp+import Net.SockDiag import Net.Tcp-import Net.IP-import Net.Bitset+import System.Exit+import Test.HUnit -import Net.IPv4 (localhost)-import Numeric (readHex) import Data.Text (Text) import qualified Data.Text as T+import Net.IPv4 (localhost)+import Numeric (readHex) -- TODO reestablish this testEmpty = TestCase $ assertEqual@@ -65,7 +65,7 @@ loadTcpFlagsFromHex :: Text -> [TcpFlag] loadTcpFlagsFromHex text = case readHex (T.unpack $ T.drop 2 text) of [(n, "")] -> fromBitMask n- _ -> error $ "TcpFlags: could not parse " ++ T.unpack text+ _ -> error $ "TcpFlags: could not parse " ++ T.unpack text -- connectionFilter = TestCase $ assertEqual