module Hans.Layer.Arp (
ArpHandle
, runArpLayer
, arpWhoHas
, arpIP4Packet
, addLocalAddress
) where
import Hans.Address.IP4 (IP4,parseIP4,renderIP4)
import Hans.Address.Mac (Mac,parseMac,renderMac,broadcastMac)
import Hans.Channel
import Hans.Layer
import Hans.Layer.Arp.Table
import Hans.Layer.Ethernet
import Hans.Message.Arp
(ArpPacket(..),parseArpPacket,renderArpPacket,ArpOper(..))
import Hans.Message.EthernetFrame
import Hans.Timers (delay_)
import Hans.Utils
import Control.Concurrent (forkIO,takeMVar,putMVar,newEmptyMVar)
import Control.Monad (forM_,mplus,guard,unless,when)
import MonadLib (BaseM(inBase),set,get)
import qualified Data.ByteString.Lazy as L
import qualified Data.Map as Map
import qualified Data.ByteString as S
type ArpHandle = Channel (Arp ())
runArpLayer :: ArpHandle -> EthernetHandle -> IO ()
runArpLayer h eth = do
addEthernetHandler eth (EtherType 0x0806) (send h . handleIncoming)
let i = emptyArpState h eth
void (forkIO (loopLayer "arp" i (receive h) id))
arpWhoHas :: BaseM m IO => ArpHandle -> IP4 -> m (Maybe Mac)
arpWhoHas h !ip = inBase $ do
var <- newEmptyMVar
send h (whoHas ip (putMVar var))
takeMVar var
arpIP4Packet :: ArpHandle -> IP4 -> IP4 -> L.ByteString -> IO ()
arpIP4Packet h !src !dst !pkt = send h (handleOutgoing src dst pkt)
addLocalAddress :: ArpHandle -> IP4 -> Mac -> IO ()
addLocalAddress h !ip !mac = send h (handleAddAddress ip mac)
type Arp = Layer ArpState
data ArpState = ArpState
{ arpTable :: ArpTable
, arpAddrs :: Map.Map IP4 Mac
, arpWaiting :: Map.Map IP4 [Maybe Mac -> IO ()]
, arpEthernet :: EthernetHandle
, arpSelf :: ArpHandle
}
emptyArpState :: ArpHandle -> EthernetHandle -> ArpState
emptyArpState h eth = ArpState
{ arpTable = Map.empty
, arpAddrs = Map.empty
, arpWaiting = Map.empty
, arpEthernet = eth
, arpSelf = h
}
ethernetHandle :: Arp EthernetHandle
ethernetHandle = arpEthernet `fmap` get
addEntry :: IP4 -> Mac -> Arp ()
addEntry spa sha = do
state <- get
now <- time
let table' = addArpEntry now spa sha (arpTable state)
table' `seq` set state { arpTable = table' }
runWaiting spa (Just sha)
addWaiter :: IP4 -> (Maybe Mac -> IO ()) -> Arp ()
addWaiter addr cont = do
state <- get
set state { arpWaiting = Map.alter f addr (arpWaiting state) }
where
f Nothing = Just [cont]
f (Just ks) = Just (cont:ks)
runWaiting :: IP4 -> Maybe Mac -> Arp ()
runWaiting spa sha = do
state <- get
let (mb,waiting') = Map.updateLookupWithKey f spa (arpWaiting state)
where f _ _ = Nothing
let run cb = output (cb sha)
mapM_ run (maybe [] reverse mb)
waiting' `seq` set state { arpWaiting = waiting' }
updateExistingEntry :: IP4 -> Mac -> Arp Bool
updateExistingEntry spa sha = do
state <- get
let update = do
guard (spa `Map.member` arpTable state)
addEntry spa sha
return True
update `mplus` return False
localHwAddress :: IP4 -> Arp Mac
localHwAddress pa = do
state <- get
just (Map.lookup pa (arpAddrs state))
sendArpPacket :: ArpPacket Mac IP4 -> Arp ()
sendArpPacket msg = do
eth <- ethernetHandle
let frame = EthernetFrame
{ etherSource = arpSHA msg
, etherDest = arpTHA msg
, etherType = 0x0806
}
body = renderArpPacket renderMac renderIP4 msg
output (sendEthernet eth frame body)
advanceArpTable :: Arp ()
advanceArpTable = do
now <- time
state <- get
let (table', timedOut) = stepArpTable now (arpTable state)
set state { arpTable = table' }
forM_ timedOut $ \ x -> runWaiting x Nothing
whoHas :: IP4 -> (Maybe Mac -> IO ()) -> Arp ()
whoHas ip k = (k' =<< localHwAddress ip) `mplus` query
where
k' addr = output (k (Just addr))
query = do
advanceArpTable
state <- get
case lookupArpEntry ip (arpTable state) of
KnownAddress mac -> k' mac
Pending -> addWaiter ip k
Unknown -> do
let addrs = Map.toList (arpAddrs state)
msg (spa,sha) = ArpPacket
{ arpHwType = 0x1
, arpPType = 0x0800
, arpSHA = sha
, arpSPA = spa
, arpTHA = broadcastMac
, arpTPA = ip
, arpOper = ArpRequest
}
now <- time
let table' = addPending now ip (arpTable state)
set state { arpTable = table' }
addWaiter ip k
mapM_ (sendArpPacket . msg) addrs
output (delay_ 10000 (send (arpSelf state) advanceArpTable))
handleIncoming :: S.ByteString -> Arp ()
handleIncoming bs = do
msg <- liftRight (parseArpPacket parseMac parseIP4 bs)
let sha = arpSHA msg
let spa = arpSPA msg
merge <- updateExistingEntry spa sha
let tpa = arpTPA msg
lha <- localHwAddress tpa
unless merge (addEntry spa sha)
when (arpOper msg == ArpRequest) $ do
let msg' = msg { arpSHA = lha , arpSPA = tpa
, arpTHA = sha , arpTPA = spa
, arpOper = ArpReply }
sendArpPacket msg'
handleAddAddress :: IP4 -> Mac -> Arp ()
handleAddAddress ip mac = do
state <- get
let addrs' = Map.insert ip mac (arpAddrs state)
addrs' `seq` set state { arpAddrs = addrs' }
handleOutgoing :: IP4 -> IP4 -> L.ByteString -> Arp ()
handleOutgoing src dst body = do
eth <- ethernetHandle
lha <- localHwAddress src
let frame dha = EthernetFrame
{ etherDest = dha
, etherSource = lha
, etherType = 0x0800
}
whoHas dst $ \ res -> case res of
Nothing -> return ()
Just dha -> sendEthernet eth (frame dha) body