module Monky.IP
( IPHandle
, getSocket
, getAddresses
, AddressFamily(..)
, IP(..)
, getRawFd
, subscribeToEvents
, handleNext
)
where
import System.IO (hPutStrLn, stderr)
import Data.Bits ((.|.))
import Data.Maybe (mapMaybe)
import Data.Word (Word32)
import System.Posix.Types (Fd)
import System.Linux.Netlink
import System.Linux.Netlink.Constants hiding (AddressFamily)
import System.Linux.Netlink.Route
import qualified Data.ByteString.Char8 as BSC (pack)
import qualified Data.ByteString as BS (singleton, append)
import qualified Data.Map as M
import Monky.IP.Raw
data IPHandle = IPHandle NetlinkSocket AddressFamily Word32
cRTNLGRP_IPV4_IFADDR :: Num a => a
cRTNLGRP_IPV4_IFADDR = 5
cRTNLGRP_IPV6_IFADDR :: Num a => a
cRTNLGRP_IPV6_IFADDR = 9
linkQuery :: String -> RoutePacket
linkQuery name =
let flags = fNLM_F_REQUEST
header = Header eRTM_GETLINK flags 0 0
msg = NLinkMsg 0 0 0
attrs = M.fromList [(eIFLA_IFNAME, BSC.pack name `BS.append` BS.singleton 0)]
in
Packet header msg attrs
getInterfaceID :: NetlinkSocket -> String -> IO Word32
getInterfaceID sock name = do
interfaces <- query sock $ linkQuery name
let ids = map (\(Packet _ (NLinkMsg _ index _) _) -> index) interfaces
return $ head ids
getSocket
:: String
-> AddressFamily
-> IO IPHandle
getSocket name fam = do
sock <- makeSocket
iid <- getInterfaceID sock name
return $ IPHandle sock fam iid
addressQuery :: AddressFamily -> RoutePacket
addressQuery fam =
let flags = fNLM_F_REQUEST .|. fNLM_F_MATCH .|. fNLM_F_ROOT
header = Header eRTM_GETADDR flags 0 0
msg = NAddrMsg (familyToNum fam) 0 0 0 0
attrs = M.empty
in
Packet header msg attrs
getAddresses :: IPHandle -> IO [IP]
getAddresses (IPHandle sock fam iid) = do
packs <- query sock $ addressQuery fam
let matching = filter (\(Packet _ (NAddrMsg _ _ _ _ aid) _) -> aid == iid) packs
let addrs = mapMaybe (M.lookup eIFLA_ADDRESS . packetAttributes) matching
return $ map (ipFromBS) addrs
getRawFd :: IPHandle -> Fd
getRawFd (IPHandle sock _ _) = getNetlinkFd sock
subscribeToEvents :: IPHandle -> IO ()
subscribeToEvents (IPHandle sock fam _) =
let grps = case fam of
AF_UNSPEC -> [cRTNLGRP_IPV6_IFADDR, cRTNLGRP_IPV4_IFADDR]
AF_INET -> [cRTNLGRP_IPV4_IFADDR]
AF_INET6 -> [cRTNLGRP_IPV6_IFADDR]
in
mapM_ (joinMulticastGroup sock) grps
handleNext
:: IPHandle
-> (IP -> IO ())
-> (IP -> IO ())
-> IO ()
handleNext (IPHandle sock _ iid) add remove = do
evt <- recvOne sock
let matching = filter (\(Packet _ (NAddrMsg _ _ _ _ aid) _) -> aid == iid) evt
let addrs = mapMaybe transform matching
mapM_ handle addrs
where handle (cmd, addr)
| cmd == eRTM_NEWADDR = add addr
| cmd == eRTM_DELADDR = remove addr
| otherwise = hPutStrLn stderr ("Got unexpeced message while handling IPevents: " ++ show cmd)
transform :: RoutePacket -> Maybe (MessageType, IP)
transform (Packet (Header cmd _ _ _) _ attrs) =
fmap ((cmd,) . ipFromBS) . M.lookup eIFLA_ADDRESS $ attrs
transform err = error ("Something went wrong while handling IP events: " ++ show err)