module Hans.IP4.ArpTable (
ArpTable(), newArpTable,
addEntry,
markUnreachable,
lookupEntry,
resolveAddr, QueryResult(..),
WaitStrategy(), blockingStrategy, writeChanStrategy
) where
import Hans.Config (Config(..))
import Hans.Device.Types (DeviceStats,updateError,statTX)
import Hans.Ethernet (Mac)
import qualified Hans.HashTable as HT
import Hans.IP4.Packet (IP4)
import Hans.Threads (forkNamed)
import Hans.Time (toUSeconds)
import Control.Concurrent
(threadDelay,MVar,newEmptyMVar,ThreadId,tryPutMVar)
import qualified Control.Concurrent.BoundedChan as BC
import Control.Monad (forever)
import Data.Time.Clock
(UTCTime,NominalDiffTime,addUTCTime,getCurrentTime)
data ArpTable = ArpTable { atMacs :: !(HT.HashTable IP4 Entry)
, atLifetime :: !NominalDiffTime
, atPurgeThread :: !ThreadId
}
data Entry = Waiting [Maybe Mac -> IO ()]
| Present !UTCTime !Mac
newArpTable :: Config -> IO ArpTable
newArpTable Config { .. } =
do atMacs <- HT.newHashTable cfgArpTableSize
atPurgeThread <- forkNamed "Arp Purge Thread"
(purgeArpTable cfgArpTableLifetime atMacs)
return ArpTable { atLifetime = cfgArpTableLifetime, .. }
purgeArpTable :: NominalDiffTime -> HT.HashTable IP4 Entry -> IO ()
purgeArpTable lifetime table = forever $
do now <- getCurrentTime
HT.filterHashTable (update now) table
threadDelay delay
where
update _ _ Waiting{} = False
update now _ (Present expire _) = expire < now
delay = toUSeconds lifetime
lookupEntry :: ArpTable -> IP4 -> IO (Maybe Mac)
lookupEntry ArpTable { .. } spa =
do mb <- HT.lookup spa atMacs
case mb of
Just (Present _ mac) -> return (Just mac)
_ -> return Nothing
addEntry :: ArpTable -> IP4 -> Mac -> IO ()
addEntry ArpTable { .. } spa sha =
do now <- getCurrentTime
let end = addUTCTime atLifetime now
waiters <- HT.alter (update end) spa atMacs
mapM_ ($ Just sha) waiters
where
update expire (Just (Waiting ks)) = (Just (Present expire sha), ks)
update expire (Just Present{}) = (Just (Present expire sha), [])
update expire Nothing = (Just (Present expire sha), [])
markUnreachable :: ArpTable -> IP4 -> IO ()
markUnreachable ArpTable { .. } addr =
do waiters <- HT.alter update addr atMacs
mapM_ ($ Nothing) waiters
where
update (Just (Waiting ks)) = (Nothing, ks)
update ent@(Just Present{}) = (ent, [])
update Nothing = (Nothing,[])
newtype WaitStrategy res = WaitStrategy { getWaiter :: IO (Maybe Mac -> IO (), res) }
blockingStrategy :: WaitStrategy (MVar (Maybe Mac))
blockingStrategy = WaitStrategy $
do mvar <- newEmptyMVar
let write mb = do _ <- tryPutMVar mvar mb
return ()
return (write, mvar)
writeChanStrategy :: Maybe DeviceStats -> (Maybe Mac -> Maybe msg) -> BC.BoundedChan msg
-> WaitStrategy ()
writeChanStrategy mbStats f chan = WaitStrategy (return (handler,()))
where
handler mb =
case f mb of
Just msg -> do written <- BC.tryWriteChan chan msg
case mbStats of
Just stats | not written -> updateError statTX stats
_ -> return ()
Nothing -> return ()
data QueryResult res = Known !Mac
| Unknown !Bool res
resolveAddr :: ArpTable -> IP4 -> WaitStrategy res -> IO (QueryResult res)
resolveAddr arp addr strategy =
do mb <- lookupEntry arp addr
case mb of
Just mac -> return (Known mac)
Nothing -> registerWaiter arp addr strategy
registerWaiter :: ArpTable -> IP4 -> WaitStrategy res -> IO (QueryResult res)
registerWaiter ArpTable { .. } addr strategy =
do waiter <- getWaiter strategy
HT.alter (update waiter) addr atMacs
where
update (w,r) (Just (Waiting ws)) = (Just (Waiting (w:ws)), Unknown False r)
update _ ent@(Just (Present _ mac)) = (ent, Known mac)
update (w,r) Nothing = (Just (Waiting [w]), Unknown True r)