module Nettle.FRPControl.TrafficGenerator
(
TrafficGenerator
, PacketSendCommand
, ConsoleMessage
, UDPPort
, driveTrafficGenerator
) where
import Network.Socket
import Data.Word
import Data.Bits
import Control.Exception
import Nettle.IPv4.IPAddress
import Nettle.FRPControl.AFRP
import Control.Concurrent.MVar
import Control.Concurrent
import Data.Time.Clock (getCurrentTime, diffUTCTime)
import Control.Monad
type TrafficGenerator = SF () (Event PacketSendCommand)
type ConsoleMessage = String
type PacketSendCommand = [(IPAddress, UDPPort, String)]
type UDPPort = Word16
driveTrafficGenerator :: SF () (Event PacketSendCommand, Event ConsoleMessage) -> IO ()
driveTrafficGenerator sf = do
cntVar <- newMVar 0
lastSenseTimeVar <- newEmptyMVar
inCh <- newChan
let initiator = do forkIO $ genClockSignal inCh
t <- getCurrentTime
putMVar lastSenseTimeVar t
return ()
let sensor _ = do ma <- readChan inCh
t' <- getCurrentTime
t <- swapMVar lastSenseTimeVar t'
let delta = fromRational (toRational (diffUTCTime t' t))
return (delta, ma)
let actuator sock _ (e1,e2) =
do event (return ()) (mapM_ send) e1
event (return ()) putStr e2
return False
where send (addr,port,msg) = let ipAddr = toHostAddress addr
udpPortNum = PortNum (flipBytes port)
dest = SockAddrInet udpPortNum ipAddr
in do sendTo sock msg dest
modifyMVar_ cntVar (return . (+1))
return ()
sock <- socket AF_INET Datagram defaultProtocol
finally (reactimate initiator sensor (actuator sock) sf)
(do sClose sock
cnt <- readMVar cntVar
putStrLn ("Number of packets sent: " ++ show cnt)
)
where
genClockSignal ch =
forever (threadDelay clockCycle >> writeChan ch Nothing)
where clockCycle = 1000
flipBytes :: Word16 -> Word16
flipBytes word = shiftL lbyte 8 + hbyte
where hbyte = shiftR word 8 .&. (2^8 1)
lbyte = word .&. (2^8 1)
toHostAddress :: IPAddress -> HostAddress
toHostAddress addr = shiftL (fromIntegral b4) 24 +
shiftL (fromIntegral b3) 16 +
shiftL (fromIntegral b2) 8 +
fromIntegral b1
where (b1,b2,b3,b4) = addressToOctets addr