module Net.ARP_Protocol(
Interface(..),CacheDump,initialize)
where
import Net.Concurrent
import Control.Monad
import qualified Net.Ethernet as Eth
import qualified Net.IPv4 as IP
import Net.ARP as ARP
import Text.Show.Functions
import Net.Utils(doReq)
import Monad.Util(loop)
data Interface m
= Interface {
lookup :: IP.Addr -> m (Maybe Eth.Addr),
dump :: m CacheDump
}
type Callback m = ARP.Packet -> m ()
type Cache m = [(IP.Addr,CacheEntry m)]
data CacheEntry m = Waiting [Maybe Eth.Addr->m ()]
| Known Eth.Addr
initCache = [] :: Cache m
findIP ip cache =
case break ((==ip).fst) cache of
(other1,(_,entry):other2) -> Just (entry,other1++other2)
_ -> Nothing
type CacheDump = [(IP.Addr,Maybe Eth.Addr)]
dumpCache cache = [(ip,dumpEntry e)|(ip,e)<-cache]
where
dumpEntry (Known mac) = Just mac
dumpEntry _ = Nothing
data Req m
= Lookup IP.Addr (Maybe Eth.Addr->m ())
| Dump (CacheDump-> m ())
| FromNetwork ARP.Packet
| Timeout Int IP.Addr
deriving (Show)
initialize debug eth myIP =
do reqChan <- newChan
let ask ipaddr = if ipaddr==bcastIP
then return (Just Eth.broadcastAddr)
else doReq reqChan (Lookup ipaddr)
dump = doReq reqChan Dump
tx = Eth.tx eth
me = (Eth.myMAC eth,myIP)
iface = Interface ask dump
fork $ loop $ writeChan reqChan . FromNetwork =<< Eth.rx eth
fork (server debug tx me reqChan initCache)
return iface
where
bcastIP = IP.broadcastAddr myIP
server debug tx me@(_, myIP) reqChan = loop
where
loop cache =
do msg <- readChan reqChan
case msg of
Dump reply -> reply (dumpCache cache) >> loop cache
Lookup ipaddr reply ->
case findIP ipaddr cache of
Just (Known ha,_) -> do reply (Just ha); loop cache
Just (Waiting clients,other) ->
loop ((ipaddr,Waiting (reply:clients)):other)
_ ->
do txreq 3 ipaddr
loop ((ipaddr,Waiting [reply]):cache)
FromNetwork p ->
do cache' <- update_cache cache p
when (targetIP p == myIP && opcode p==Request) $
tx (arpReply me (senderHA p) (senderIP p))
loop cache'
Timeout 0 ipaddr ->
do debug $ "ARP request for "++show ipaddr++" timed out"
loop =<< update_timeout cache ipaddr
Timeout n ipaddr ->
case findIP ipaddr cache of
Just (Waiting _,_) -> txreq (n1) ipaddr >> loop cache
_ -> loop cache
txreq retries ipaddr =
do tx (arpRequest me ipaddr)
fork $ do delay 500000
writeChan reqChan (Timeout retries ipaddr)
update_timeout cache ipaddr =
case findIP ipaddr cache of
Just (entry,other) ->
case entry of
Known oldHA -> return cache
Waiting clients ->
do mapM_ ($ Nothing) clients
return other
update_cache cache Packet{senderIP=sIP,senderHA=sHA,targetIP=tIP} =
case findIP sIP cache of
Just (entry,other) ->
case entry of
Known oldHA -> return $ if sHA==oldHA
then cache
else entry':other
Waiting clients ->
do mapM_ ($ (Just sHA)) clients
return $ entry':other
_ -> return $ if tIP==myIP
then entry':cache
else cache
where
entry' = (sIP,Known sHA)
arpRequest me = arpMessage Request me Eth.broadcastAddr
arpReply = arpMessage Reply
arpMessage op (myMAC, myIP) targetMAC targetIP =
Eth.Packet { Eth.dest = targetMAC,
Eth.source = myMAC,
Eth.packType = Eth.ARP,
Eth.content = arpPacket }
where
arpPacket = Packet op myMAC myIP targetMAC targetIP