{- Module: Net.Mptcp.Upstream.Commands Description : Description Maintainer : matt Portability : Linux -} {-# LANGUAGE CPP #-} module Net.Mptcp.Upstream.Commands ( attrToPair , newSubflowPkt , makeAttribute , resetConnectionPkt , subflowFromAttributes ) where -- mptcp-pm import Net.Mptcp.Upstream.Constants import Net.Mptcp.Netlink import Net.Mptcp.Types import Net.Mptcp.Utils import Net.Mptcp.Connection import Net.Stream -- hackage -- import Control.Exception (assert) import Control.Lens ((^.)) import Data.Word (Word16, Word8, Word32) import Data.Serialize.Get import Data.Serialize.Put import Data.ByteString import qualified Data.Map as Map import Net.IP import Net.IPv4 import Net.IPv6 import Net.IPAddress import System.Linux.Netlink import System.Linux.Netlink.Constants (fNLM_F_ACK, fNLM_F_REQUEST, fNLM_F_MATCH, fNLM_F_ROOT, eAF_INET) import Data.Bits ((.|.)) import System.Linux.Netlink.GeNetlink import Data.Maybe import Debug.Trace import Net.Tcp.Connection 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 {-| 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 hasFamily :: [MptcpAttribute] -> Bool hasFamily = Prelude.any (isAttribute (SubflowFamily eAF_INET)) -- -- 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) = #ifdef EXPERIMENTAL_CWND (fromEnum MPTCP_ATTR_CWND, runPut $ putWord32host limit) #else error "not supported" #endif 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 -- 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 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 -- |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" dumpAttribute :: Int -> ByteString -> String dumpAttribute attrId value = show $ makeAttribute attrId value -- 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 -- need to prepare a request -- type GenlPacket a = Packet (GenlData a) -- REQUIRES: LOC_ID / TOKEN -- TODO pass MptcpSubflow resetConnectionPkt :: MptcpSocket -> [MptcpAttribute] -> MptcpPacket resetConnectionPkt (MptcpSocket _sock fid) attrs = error "reset not implemented yet" -- let -- _cmd = MPTCP_CMD_REMOVE -- in -- assert (hasLocAddr attrs) $ genMptcpRequest fid MPTCP_CMD_REMOVE False attrs -- connectionToken connectionAttrs :: MptcpConnection -> [MptcpAttribute] connectionAttrs con = [ MptcpAttrToken $ (con ^. mpconServerConfig ^. mecToken) ] -- pass token ? subflowAttrs :: MptcpSubflow -> [MptcpAttribute] subflowAttrs (MptcpSubflow con _ prio localId remoteId mbIf) = [ LocalLocatorId $ localId , RemoteLocatorId $ remoteId , SubflowFamily $ getAddressFamily (conTcpServerIp con) , SubflowDestAddress $ conTcpServerIp con , SubflowDestPort $ conTcpServerPort con -- should fail if doesn't exist , SubflowInterface $ fromJust $ mbIf -- https://github.com/multipath-tcp/mptcp/issues/338 , SubflowSourceAddress $ conTcpClientIp con , SubflowSourcePort $ conTcpClientPort con ] -- |Generate a request to create a new subflow capCwndPkt :: MptcpSocket -> MptcpConnection -> Word32 -- ^Limit to apply to congestion window -> MptcpSubflow -> Either String MptcpPacket capCwndPkt (MptcpSocket _ fid) mptcpCon limit sf = #ifdef EXPERIMENTAL_CWND assert (hasFamily attrs) (Right 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 #else error "support for capping Cwnds not compiled" #endif -- sport/backup/intf are optional newSubflowPkt :: MptcpSocket -> MptcpConnection -> MptcpSubflow -> MptcpPacket newSubflowPkt (MptcpSocket _ fid) mptcpCon sf = error "undefined" -- assert (hasFamily attrs) pkt -- where -- _cmd = MPTCP_CMD_SUB_CREATE -- attrs = connectionAttrs mptcpCon ++ subflowAttrs sf -- pkt = genMptcpRequest fid MPTCP_CMD_SUB_CREATE False attrs -- | 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 #ifdef EXPERIMENTAL_CWND MPTCP_ATTR_CWND -> undefined #endif MPTCP_ATTR_FLAGS -> trace "makeAttribute ATTR_FLAGS" Nothing MPTCP_ATTR_UNSPEC -> undefined MPTCP_ATTR_RESET_REASON -> undefined MPTCP_ATTR_RESET_FLAGS -> undefined -- mptcpAttributesToMap :: [MptcpAttribute] -> Attributes -- mptcpAttributesToMap attrs = -- Map.fromList $map mptcpAttributeToTuple attrs -- |Converts / should be a maybe ? -- TODO simplify subflowFromAttributes :: Attributes -> MptcpSubflow subflowFromAttributes attrs = let -- expects a ByteString SubflowSourcePort sport = fromJust $ makeAttributeFromMaybe MPTCP_ATTR_SPORT attrs SubflowDestPort dport = fromJust $ makeAttributeFromMaybe MPTCP_ATTR_DPORT attrs SubflowSourceAddress srcIp' = fromJust $ makeAttributeFromMaybe srcAttr attrs -- eAF_INET6 -> fromJust $ makeAttributeFromMaybe MPTCP_ATTR_SADDR6 attrs -- ipFromAttributes True attrs srcAttr = case family of 2 -> MPTCP_ATTR_SADDR4 10 -> MPTCP_ATTR_SADDR6 _ -> error "Unsupported address family" SubflowDestAddress dstIp' = fromJust $ makeAttributeFromMaybe dstAttr attrs dstAttr = case family of 2 -> MPTCP_ATTR_DADDR4 10 -> MPTCP_ATTR_DADDR6 _ -> error "Unsupported address family" 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 SubflowFamily family = fromJust $ makeAttributeFromMaybe MPTCP_ATTR_FAMILY attrs -- sfFamily = getPort $ fromJust (Map.lookup (fromEnum MPTCP_ATTR_FAMILY) attrs) prio = Nothing -- (SubflowPriority N) -- using fake streamId con = TcpConnection srcIp' dstIp' sport dport (StreamId 0) in -- TODO fix sfFamily -- using fake token -- (Just intfId) -- TODO set joinToken MptcpSubflow con Nothing prio lid rid (Just intfId)