diff --git a/Net/Bitset.hs b/Net/Bitset.hs deleted file mode 100644 --- a/Net/Bitset.hs +++ /dev/null @@ -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 diff --git a/Net/IPAddress.hs b/Net/IPAddress.hs deleted file mode 100644 --- a/Net/IPAddress.hs +++ /dev/null @@ -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) diff --git a/Net/Mptcp.hs b/Net/Mptcp.hs deleted file mode 100644 --- a/Net/Mptcp.hs +++ /dev/null @@ -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 - diff --git a/Net/Mptcp/PathManager.hs b/Net/Mptcp/PathManager.hs deleted file mode 100644 --- a/Net/Mptcp/PathManager.hs +++ /dev/null @@ -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: and - -- eno1: 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 }) diff --git a/Net/Mptcp/PathManager/Default.hs b/Net/Mptcp/PathManager/Default.hs deleted file mode 100644 --- a/Net/Mptcp/PathManager/Default.hs +++ /dev/null @@ -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 - diff --git a/Net/SockDiag.hs b/Net/SockDiag.hs deleted file mode 100644 --- a/Net/SockDiag.hs +++ /dev/null @@ -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< 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 - diff --git a/Net/Tcp.hs b/Net/Tcp.hs deleted file mode 100644 --- a/Net/Tcp.hs +++ /dev/null @@ -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 diff --git a/Net/Tcp/Definitions.hs b/Net/Tcp/Definitions.hs deleted file mode 100644 --- a/Net/Tcp/Definitions.hs +++ /dev/null @@ -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 == - - diff --git a/README.md b/README.md --- a/README.md +++ b/README.md @@ -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/ diff --git a/hs/daemon.hs b/hs/daemon.hs deleted file mode 100644 --- a/hs/daemon.hs +++ /dev/null @@ -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" diff --git a/mptcp-pm.cabal b/mptcp-pm.cabal --- a/mptcp-pm.cabal +++ b/mptcp-pm.cabal @@ -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 .... diff --git a/src/Net/Bitset.hs b/src/Net/Bitset.hs new file mode 100644 --- /dev/null +++ b/src/Net/Bitset.hs @@ -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 diff --git a/src/Net/IPAddress.hs b/src/Net/IPAddress.hs new file mode 100644 --- /dev/null +++ b/src/Net/IPAddress.hs @@ -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) diff --git a/src/Net/Mptcp.hs b/src/Net/Mptcp.hs new file mode 100644 --- /dev/null +++ b/src/Net/Mptcp.hs @@ -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 + diff --git a/src/Net/Mptcp/Constants.chs b/src/Net/Mptcp/Constants.chs new file mode 100644 --- /dev/null +++ b/src/Net/Mptcp/Constants.chs @@ -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 + +-- {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 #} + diff --git a/src/Net/Mptcp/PathManager.hs b/src/Net/Mptcp/PathManager.hs new file mode 100644 --- /dev/null +++ b/src/Net/Mptcp/PathManager.hs @@ -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: and + -- eno1: 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 }) diff --git a/src/Net/Mptcp/PathManager/Default.hs b/src/Net/Mptcp/PathManager/Default.hs new file mode 100644 --- /dev/null +++ b/src/Net/Mptcp/PathManager/Default.hs @@ -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 + diff --git a/src/Net/SockDiag.hs b/src/Net/SockDiag.hs new file mode 100644 --- /dev/null +++ b/src/Net/SockDiag.hs @@ -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< 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 + diff --git a/src/Net/SockDiag/Constants.chs b/src/Net/SockDiag/Constants.chs new file mode 100644 --- /dev/null +++ b/src/Net/SockDiag/Constants.chs @@ -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 + +-- 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 + +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 + diff --git a/src/Net/Tcp.hs b/src/Net/Tcp.hs new file mode 100644 --- /dev/null +++ b/src/Net/Tcp.hs @@ -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 diff --git a/src/Net/Tcp/Constants.chs b/src/Net/Tcp/Constants.chs new file mode 100644 --- /dev/null +++ b/src/Net/Tcp/Constants.chs @@ -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 + +-- 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 + + +{#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 + diff --git a/src/Net/Tcp/Definitions.hs b/src/Net/Tcp/Definitions.hs new file mode 100644 --- /dev/null +++ b/src/Net/Tcp/Definitions.hs @@ -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 == + + diff --git a/src/app/Main.hs b/src/app/Main.hs new file mode 100644 --- /dev/null +++ b/src/app/Main.hs @@ -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 ) diff --git a/test/Main.hs b/test/Main.hs --- a/test/Main.hs +++ b/test/Main.hs @@ -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