module Net.ARP_Protocol(
  Interface(..),CacheDump,initialize)
  where

-- Implementation of the ARP Protocol and an ARP cache
-- See http://rfc.net/rfc0826.html

import Net.Concurrent
import Control.Monad
import qualified Net.Ethernet as Eth
import qualified Net.IPv4 as IP
import Net.ARP as ARP
--import Net.PacketParsing
import Text.Show.Functions
import Net.Utils(doReq)
import Monad.Util(loop)

data Interface m
    = Interface {
      forall (m :: * -> *). Interface m -> Addr -> m (Maybe Addr)
lookup :: IP.Addr -> m (Maybe Eth.Addr),
      forall (m :: * -> *). Interface m -> m CacheDump
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
initCache = [] :: Cache m

findIP :: b -> [(b, a)] -> Maybe (a, [(b, a)])
findIP b
ip [(b, a)]
cache =
    case ((b, a) -> Bool) -> [(b, a)] -> ([(b, a)], [(b, a)])
forall a. (a -> Bool) -> [a] -> ([a], [a])
break ((b -> b -> Bool
forall a. Eq a => a -> a -> Bool
==b
ip)(b -> Bool) -> ((b, a) -> b) -> (b, a) -> Bool
forall b c a. (b -> c) -> (a -> b) -> a -> c
.(b, a) -> b
forall a b. (a, b) -> a
fst) [(b, a)]
cache of
      ([(b, a)]
other1,(b
_,a
entry):[(b, a)]
other2) -> (a, [(b, a)]) -> Maybe (a, [(b, a)])
forall a. a -> Maybe a
Just (a
entry,[(b, a)]
other1[(b, a)] -> [(b, a)] -> [(b, a)]
forall a. [a] -> [a] -> [a]
++[(b, a)]
other2)
      ([(b, a)], [(b, a)])
_ -> Maybe (a, [(b, a)])
forall a. Maybe a
Nothing

type CacheDump = [(IP.Addr,Maybe Eth.Addr)]

dumpCache :: [(a, CacheEntry m)] -> [(a, Maybe Addr)]
dumpCache [(a, CacheEntry m)]
cache = [(a
ip,CacheEntry m -> Maybe Addr
forall {m :: * -> *}. CacheEntry m -> Maybe Addr
dumpEntry CacheEntry m
e)|(a
ip,CacheEntry m
e)<-[(a, CacheEntry m)]
cache]
  where
    dumpEntry :: CacheEntry m -> Maybe Addr
dumpEntry (Known Addr
mac) = Addr -> Maybe Addr
forall a. a -> Maybe a
Just Addr
mac
    dumpEntry CacheEntry m
_ = Maybe Addr
forall a. Maybe a
Nothing

--------------------------------------------------------------------------------

data Req m
   = Lookup IP.Addr (Maybe Eth.Addr->m ())
   | Dump (CacheDump-> m ())
   | FromNetwork ARP.Packet
   | Timeout Int IP.Addr
   deriving (Int -> Req m -> ShowS
[Req m] -> ShowS
Req m -> String
(Int -> Req m -> ShowS)
-> (Req m -> String) -> ([Req m] -> ShowS) -> Show (Req m)
forall a.
(Int -> a -> ShowS) -> (a -> String) -> ([a] -> ShowS) -> Show a
forall (m :: * -> *). Int -> Req m -> ShowS
forall (m :: * -> *). [Req m] -> ShowS
forall (m :: * -> *). Req m -> String
$cshowsPrec :: forall (m :: * -> *). Int -> Req m -> ShowS
showsPrec :: Int -> Req m -> ShowS
$cshow :: forall (m :: * -> *). Req m -> String
show :: Req m -> String
$cshowList :: forall (m :: * -> *). [Req m] -> ShowS
showList :: [Req m] -> ShowS
Show)

--initialize :: (String->IO())->Eth.Interface->IP.Addr-> IO (Interface,Callback)
initialize :: (String -> m a)
-> Interface m Packet (Packet Packet) -> Addr -> m (Interface m)
initialize String -> m a
debug Interface m Packet (Packet Packet)
eth Addr
myIP =
  do c (Req m)
reqChan <- m (c (Req m))
forall a. m (c a)
forall (c :: * -> *) (io :: * -> *) a. ChannelIO c io => io (c a)
newChan
     let ask :: Addr -> m (Maybe Addr)
ask Addr
ipaddr = if Addr
ipaddrAddr -> Addr -> Bool
forall a. Eq a => a -> a -> Bool
==Addr
bcastIP
		      then Maybe Addr -> m (Maybe Addr)
forall a. a -> m a
forall (m :: * -> *) a. Monad m => a -> m a
return (Addr -> Maybe Addr
forall a. a -> Maybe a
Just Addr
Eth.broadcastAddr)
		      else c (Req m) -> ((Maybe Addr -> m ()) -> Req m) -> m (Maybe Addr)
forall {c :: * -> *} {m :: * -> *} {v :: * -> *} {io :: * -> *} {a}
       {b}.
(ChannelIO c m, MVarIO v m, MVarIO v io) =>
c a -> ((b -> io ()) -> a) -> m b
doReq c (Req m)
reqChan (Addr -> (Maybe Addr -> m ()) -> Req m
forall (m :: * -> *). Addr -> (Maybe Addr -> m ()) -> Req m
Lookup Addr
ipaddr)
	 dump :: m CacheDump
dump = c (Req m) -> ((CacheDump -> m ()) -> Req m) -> m CacheDump
forall {c :: * -> *} {m :: * -> *} {v :: * -> *} {io :: * -> *} {a}
       {b}.
(ChannelIO c m, MVarIO v m, MVarIO v io) =>
c a -> ((b -> io ()) -> a) -> m b
doReq c (Req m)
reqChan (CacheDump -> m ()) -> Req m
forall (m :: * -> *). (CacheDump -> m ()) -> Req m
Dump
	 tx :: Packet Packet -> m ()
tx = Interface m Packet (Packet Packet) -> Packet Packet -> m ()
forall {m :: * -> *} {i} {o}. Interface m i o -> o -> m ()
Eth.tx Interface m Packet (Packet Packet)
eth
	 me :: (Addr, Addr)
me = (Interface m Packet (Packet Packet) -> Addr
forall (m :: * -> *) i o. Interface m i o -> Addr
Eth.myMAC Interface m Packet (Packet Packet)
eth,Addr
myIP)
         iface :: Interface m
iface = (Addr -> m (Maybe Addr)) -> m CacheDump -> Interface m
forall (m :: * -> *).
(Addr -> m (Maybe Addr)) -> m CacheDump -> Interface m
Interface Addr -> m (Maybe Addr)
forall {m :: * -> *}.
(ChannelIO c m, MVarIO v m) =>
Addr -> m (Maybe Addr)
ask m CacheDump
dump
     m () -> m ThreadId
forall (io :: * -> *). ForkIO io => io () -> io ThreadId
fork (m () -> m ThreadId) -> m () -> m ThreadId
forall a b. (a -> b) -> a -> b
$ m () -> m ()
forall {m :: * -> *} {a} {b}. Monad m => m a -> m b
loop (m () -> m ()) -> m () -> m ()
forall a b. (a -> b) -> a -> b
$ c (Req m) -> Req m -> m ()
forall a. c a -> a -> m ()
forall (c :: * -> *) (io :: * -> *) a.
ChannelIO c io =>
c a -> a -> io ()
writeChan c (Req m)
reqChan (Req m -> m ()) -> (Packet -> Req m) -> Packet -> m ()
forall b c a. (b -> c) -> (a -> b) -> a -> c
. Packet -> Req m
forall (m :: * -> *). Packet -> Req m
FromNetwork (Packet -> m ()) -> m Packet -> m ()
forall (m :: * -> *) a b. Monad m => (a -> m b) -> m a -> m b
=<< Interface m Packet (Packet Packet) -> m Packet
forall {m :: * -> *} {i} {o}. Interface m i o -> m i
Eth.rx Interface m Packet (Packet Packet)
eth
     m () -> m ThreadId
forall (io :: * -> *). ForkIO io => io () -> io ThreadId
fork ((String -> m a)
-> (Packet Packet -> m ())
-> (Addr, Addr)
-> c (Req m)
-> [(Addr, CacheEntry m)]
-> m ()
forall {m :: * -> *} {c :: * -> *} {a} {b}.
(ForkIO m, DelayIO m, ChannelIO c m) =>
(String -> m a)
-> (Packet Packet -> m ())
-> (Addr, Addr)
-> c (Req m)
-> [(Addr, CacheEntry m)]
-> m b
server String -> m a
debug Packet Packet -> m ()
tx (Addr, Addr)
me c (Req m)
reqChan [(Addr, CacheEntry m)]
forall {m :: * -> *}. [(Addr, CacheEntry m)]
initCache)
     Interface m -> m (Interface m)
forall a. a -> m a
forall (m :: * -> *) a. Monad m => a -> m a
return Interface m
iface
  where
    bcastIP :: Addr
bcastIP = Addr -> Addr
IP.broadcastAddr Addr
myIP


server :: (String -> m a)
-> (Packet Packet -> m ())
-> (Addr, Addr)
-> c (Req m)
-> [(Addr, CacheEntry m)]
-> m b
server String -> m a
debug Packet Packet -> m ()
tx me :: (Addr, Addr)
me@(Addr
_, Addr
myIP) c (Req m)
reqChan = [(Addr, CacheEntry m)] -> m b
forall {b}. [(Addr, CacheEntry m)] -> m b
loop
  where
    loop :: [(Addr, CacheEntry m)] -> m b
loop [(Addr, CacheEntry m)]
cache =
      do Req m
msg <- c (Req m) -> m (Req m)
forall a. c a -> m a
forall (c :: * -> *) (io :: * -> *) a.
ChannelIO c io =>
c a -> io a
readChan c (Req m)
reqChan
	 --debug (show msg)
	 case Req m
msg of
	   Dump CacheDump -> m ()
reply -> CacheDump -> m ()
reply ([(Addr, CacheEntry m)] -> CacheDump
forall {a} {m :: * -> *}. [(a, CacheEntry m)] -> [(a, Maybe Addr)]
dumpCache [(Addr, CacheEntry m)]
cache) m () -> m b -> m b
forall a b. m a -> m b -> m b
forall (m :: * -> *) a b. Monad m => m a -> m b -> m b
>> [(Addr, CacheEntry m)] -> m b
loop [(Addr, CacheEntry m)]
cache
	   Lookup Addr
ipaddr Maybe Addr -> m ()
reply ->
	     case Addr
-> [(Addr, CacheEntry m)]
-> Maybe (CacheEntry m, [(Addr, CacheEntry m)])
forall {b} {a}. Eq b => b -> [(b, a)] -> Maybe (a, [(b, a)])
findIP Addr
ipaddr [(Addr, CacheEntry m)]
cache of
	       Just (Known Addr
ha,[(Addr, CacheEntry m)]
_) -> do Maybe Addr -> m ()
reply (Addr -> Maybe Addr
forall a. a -> Maybe a
Just Addr
ha); [(Addr, CacheEntry m)] -> m b
loop [(Addr, CacheEntry m)]
cache
	       Just (Waiting [Maybe Addr -> m ()]
clients,[(Addr, CacheEntry m)]
other) ->
		   [(Addr, CacheEntry m)] -> m b
loop ((Addr
ipaddr,[Maybe Addr -> m ()] -> CacheEntry m
forall (m :: * -> *). [Maybe Addr -> m ()] -> CacheEntry m
Waiting (Maybe Addr -> m ()
reply(Maybe Addr -> m ())
-> [Maybe Addr -> m ()] -> [Maybe Addr -> m ()]
forall a. a -> [a] -> [a]
:[Maybe Addr -> m ()]
clients))(Addr, CacheEntry m)
-> [(Addr, CacheEntry m)] -> [(Addr, CacheEntry m)]
forall a. a -> [a] -> [a]
:[(Addr, CacheEntry m)]
other)
	       Maybe (CacheEntry m, [(Addr, CacheEntry m)])
_ ->
		 do Int -> Addr -> m ThreadId
txreq Int
3 Addr
ipaddr
		    [(Addr, CacheEntry m)] -> m b
loop ((Addr
ipaddr,[Maybe Addr -> m ()] -> CacheEntry m
forall (m :: * -> *). [Maybe Addr -> m ()] -> CacheEntry m
Waiting [Maybe Addr -> m ()
reply])(Addr, CacheEntry m)
-> [(Addr, CacheEntry m)] -> [(Addr, CacheEntry m)]
forall a. a -> [a] -> [a]
:[(Addr, CacheEntry m)]
cache)
	   FromNetwork Packet
p ->
	     do [(Addr, CacheEntry m)]
cache' <- [(Addr, CacheEntry m)] -> Packet -> m [(Addr, CacheEntry m)]
forall {m :: * -> *}.
Monad m =>
[(Addr, CacheEntry m)] -> Packet -> m [(Addr, CacheEntry m)]
update_cache [(Addr, CacheEntry m)]
cache Packet
p
		Bool -> m () -> m ()
forall (f :: * -> *). Applicative f => Bool -> f () -> f ()
when (Packet -> Addr
targetIP Packet
p Addr -> Addr -> Bool
forall a. Eq a => a -> a -> Bool
== Addr
myIP Bool -> Bool -> Bool
&& Packet -> Operation
opcode Packet
pOperation -> Operation -> Bool
forall a. Eq a => a -> a -> Bool
==Operation
Request) (m () -> m ()) -> m () -> m ()
forall a b. (a -> b) -> a -> b
$
		  Packet Packet -> m ()
tx ((Addr, Addr) -> Addr -> Addr -> Packet Packet
arpReply (Addr, Addr)
me (Packet -> Addr
senderHA Packet
p) (Packet -> Addr
senderIP Packet
p))
		[(Addr, CacheEntry m)] -> m b
loop [(Addr, CacheEntry m)]
cache'
	   Timeout Int
0 Addr
ipaddr ->
             do String -> m a
debug (String -> m a) -> String -> m a
forall a b. (a -> b) -> a -> b
$ String
"ARP request for "String -> ShowS
forall a. [a] -> [a] -> [a]
++Addr -> String
forall a. Show a => a -> String
show Addr
ipaddrString -> ShowS
forall a. [a] -> [a] -> [a]
++String
" timed out"
                [(Addr, CacheEntry m)] -> m b
loop ([(Addr, CacheEntry m)] -> m b) -> m [(Addr, CacheEntry m)] -> m b
forall (m :: * -> *) a b. Monad m => (a -> m b) -> m a -> m b
=<< [(Addr, CacheEntry m)] -> Addr -> m [(Addr, CacheEntry m)]
forall {b} {m :: * -> *}.
(Eq b, Monad m) =>
[(b, CacheEntry m)] -> b -> m [(b, CacheEntry m)]
update_timeout [(Addr, CacheEntry m)]
cache Addr
ipaddr
	   Timeout Int
n Addr
ipaddr ->
	     case Addr
-> [(Addr, CacheEntry m)]
-> Maybe (CacheEntry m, [(Addr, CacheEntry m)])
forall {b} {a}. Eq b => b -> [(b, a)] -> Maybe (a, [(b, a)])
findIP Addr
ipaddr [(Addr, CacheEntry m)]
cache of
	       Just (Waiting [Maybe Addr -> m ()]
_,[(Addr, CacheEntry m)]
_) -> Int -> Addr -> m ThreadId
txreq (Int
nInt -> Int -> Int
forall a. Num a => a -> a -> a
-Int
1) Addr
ipaddr m ThreadId -> m b -> m b
forall a b. m a -> m b -> m b
forall (m :: * -> *) a b. Monad m => m a -> m b -> m b
>> [(Addr, CacheEntry m)] -> m b
loop [(Addr, CacheEntry m)]
cache
	       Maybe (CacheEntry m, [(Addr, CacheEntry m)])
_  -> [(Addr, CacheEntry m)] -> m b
loop [(Addr, CacheEntry m)]
cache

    txreq :: Int -> Addr -> m ThreadId
txreq Int
retries Addr
ipaddr =
      do Packet Packet -> m ()
tx ((Addr, Addr) -> Addr -> Packet Packet
arpRequest (Addr, Addr)
me Addr
ipaddr)
         m () -> m ThreadId
forall (io :: * -> *). ForkIO io => io () -> io ThreadId
fork (m () -> m ThreadId) -> m () -> m ThreadId
forall a b. (a -> b) -> a -> b
$ do Int -> m ()
forall (io :: * -> *). DelayIO io => Int -> io ()
delay Int
500000
		   c (Req m) -> Req m -> m ()
forall a. c a -> a -> m ()
forall (c :: * -> *) (io :: * -> *) a.
ChannelIO c io =>
c a -> a -> io ()
writeChan c (Req m)
reqChan (Int -> Addr -> Req m
forall (m :: * -> *). Int -> Addr -> Req m
Timeout Int
retries Addr
ipaddr)

    update_timeout :: [(b, CacheEntry m)] -> b -> m [(b, CacheEntry m)]
update_timeout [(b, CacheEntry m)]
cache b
ipaddr =
	case b
-> [(b, CacheEntry m)] -> Maybe (CacheEntry m, [(b, CacheEntry m)])
forall {b} {a}. Eq b => b -> [(b, a)] -> Maybe (a, [(b, a)])
findIP b
ipaddr [(b, CacheEntry m)]
cache of
          Just (CacheEntry m
entry,[(b, CacheEntry m)]
other) ->
            case CacheEntry m
entry of
	      Known Addr
oldHA -> [(b, CacheEntry m)] -> m [(b, CacheEntry m)]
forall a. a -> m a
forall (m :: * -> *) a. Monad m => a -> m a
return [(b, CacheEntry m)]
cache -- timeout after valid reply
	      Waiting [Maybe Addr -> m ()]
clients ->
                do ((Maybe Addr -> m ()) -> m ()) -> [Maybe Addr -> m ()] -> m ()
forall (t :: * -> *) (m :: * -> *) a b.
(Foldable t, Monad m) =>
(a -> m b) -> t a -> m ()
mapM_ ((Maybe Addr -> m ()) -> Maybe Addr -> m ()
forall a b. (a -> b) -> a -> b
$ Maybe Addr
forall a. Maybe a
Nothing) [Maybe Addr -> m ()]
clients
		   [(b, CacheEntry m)] -> m [(b, CacheEntry m)]
forall a. a -> m a
forall (m :: * -> *) a. Monad m => a -> m a
return [(b, CacheEntry m)]
other -- request really timed out

    update_cache :: [(Addr, CacheEntry m)] -> Packet -> m [(Addr, CacheEntry m)]
update_cache [(Addr, CacheEntry m)]
cache Packet{senderIP :: Packet -> Addr
senderIP=Addr
sIP,senderHA :: Packet -> Addr
senderHA=Addr
sHA,targetIP :: Packet -> Addr
targetIP=Addr
tIP} =
	case Addr
-> [(Addr, CacheEntry m)]
-> Maybe (CacheEntry m, [(Addr, CacheEntry m)])
forall {b} {a}. Eq b => b -> [(b, a)] -> Maybe (a, [(b, a)])
findIP Addr
sIP [(Addr, CacheEntry m)]
cache of
          Just (CacheEntry m
entry,[(Addr, CacheEntry m)]
other) ->
            case CacheEntry m
entry of
	      Known Addr
oldHA -> [(Addr, CacheEntry m)] -> m [(Addr, CacheEntry m)]
forall a. a -> m a
forall (m :: * -> *) a. Monad m => a -> m a
return ([(Addr, CacheEntry m)] -> m [(Addr, CacheEntry m)])
-> [(Addr, CacheEntry m)] -> m [(Addr, CacheEntry m)]
forall a b. (a -> b) -> a -> b
$ if Addr
sHAAddr -> Addr -> Bool
forall a. Eq a => a -> a -> Bool
==Addr
oldHA
				      then [(Addr, CacheEntry m)]
cache
				      else (Addr, CacheEntry m)
forall {m :: * -> *}. (Addr, CacheEntry m)
entry'(Addr, CacheEntry m)
-> [(Addr, CacheEntry m)] -> [(Addr, CacheEntry m)]
forall a. a -> [a] -> [a]
:[(Addr, CacheEntry m)]
other
	      Waiting [Maybe Addr -> m ()]
clients ->
                do ((Maybe Addr -> m ()) -> m ()) -> [Maybe Addr -> m ()] -> m ()
forall (t :: * -> *) (m :: * -> *) a b.
(Foldable t, Monad m) =>
(a -> m b) -> t a -> m ()
mapM_ ((Maybe Addr -> m ()) -> Maybe Addr -> m ()
forall a b. (a -> b) -> a -> b
$ (Addr -> Maybe Addr
forall a. a -> Maybe a
Just Addr
sHA)) [Maybe Addr -> m ()]
clients
		   [(Addr, CacheEntry m)] -> m [(Addr, CacheEntry m)]
forall a. a -> m a
forall (m :: * -> *) a. Monad m => a -> m a
return ([(Addr, CacheEntry m)] -> m [(Addr, CacheEntry m)])
-> [(Addr, CacheEntry m)] -> m [(Addr, CacheEntry m)]
forall a b. (a -> b) -> a -> b
$ (Addr, CacheEntry m)
forall {m :: * -> *}. (Addr, CacheEntry m)
entry'(Addr, CacheEntry m)
-> [(Addr, CacheEntry m)] -> [(Addr, CacheEntry m)]
forall a. a -> [a] -> [a]
:[(Addr, CacheEntry m)]
other
          Maybe (CacheEntry m, [(Addr, CacheEntry m)])
_ -> [(Addr, CacheEntry m)] -> m [(Addr, CacheEntry m)]
forall a. a -> m a
forall (m :: * -> *) a. Monad m => a -> m a
return ([(Addr, CacheEntry m)] -> m [(Addr, CacheEntry m)])
-> [(Addr, CacheEntry m)] -> m [(Addr, CacheEntry m)]
forall a b. (a -> b) -> a -> b
$ if Addr
tIPAddr -> Addr -> Bool
forall a. Eq a => a -> a -> Bool
==Addr
myIP
		         then (Addr, CacheEntry m)
forall {m :: * -> *}. (Addr, CacheEntry m)
entry'(Addr, CacheEntry m)
-> [(Addr, CacheEntry m)] -> [(Addr, CacheEntry m)]
forall a. a -> [a] -> [a]
:[(Addr, CacheEntry m)]
cache
			 else [(Addr, CacheEntry m)]
cache
       where
         entry' :: (Addr, CacheEntry m)
entry' = (Addr
sIP,Addr -> CacheEntry m
forall (m :: * -> *). Addr -> CacheEntry m
Known Addr
sHA)

arpRequest :: (Addr, Addr) -> Addr -> Packet Packet
arpRequest (Addr, Addr)
me = Operation -> (Addr, Addr) -> Addr -> Addr -> Packet Packet
arpMessage Operation
Request (Addr, Addr)
me Addr
Eth.broadcastAddr
arpReply :: (Addr, Addr) -> Addr -> Addr -> Packet Packet
arpReply = Operation -> (Addr, Addr) -> Addr -> Addr -> Packet Packet
arpMessage Operation
Reply

arpMessage :: Operation -> (Addr, Addr) -> Addr -> Addr -> Packet Packet
arpMessage Operation
op (Addr
myMAC, Addr
myIP) Addr
targetMAC Addr
targetIP =
    Eth.Packet { dest :: Addr
Eth.dest = Addr
targetMAC,
		 source :: Addr
Eth.source = Addr
myMAC,
		 packType :: PacketType
Eth.packType = PacketType
Eth.ARP,
		 content :: Packet
Eth.content = Packet
arpPacket }
  where
    arpPacket :: Packet
arpPacket = Operation -> Addr -> Addr -> Addr -> Addr -> Packet
Packet Operation
op Addr
myMAC Addr
myIP Addr
targetMAC Addr
targetIP