module Nettle.Servers.MultiplexedTCPServer
(
muxedTCPServer,
TCPMessage(..),
ServerPortNumber
) where
import Prelude hiding (interact, catch)
import Network.Socket (SockAddr)
import Nettle.OpenFlow.Messages
import Control.Concurrent
import Control.Exception
import Control.Monad
import qualified Data.Map as Map
import Nettle.Servers.Server
data TCPMessage a = ConnectionEstablished SockAddr
| ConnectionTerminated SockAddr
| PeerMessage SockAddr a
deriving (Show,Eq)
instance Functor TCPMessage where
fmap f (ConnectionEstablished a) = ConnectionEstablished a
fmap f (ConnectionTerminated a) = ConnectionTerminated a
fmap f (PeerMessage a x) = PeerMessage a (f x)
muxedTCPServer :: ServerPortNumber
-> IO (IO (TCPMessage (TransactionID,SCMessage)),
SockAddr -> (TransactionID,CSMessage) -> IO ())
muxedTCPServer pstring = do
server <- startOpenFlowServer Nothing pstring
addressToClientMap <- newMVar Map.empty
incomingChan <- newChan
let enqIncoming clientHandle =
do mm <- receiveFromSwitch clientHandle
case mm of
Nothing -> do modifyMVar_ addressToClientMap (return . Map.delete (switchSockAddr clientHandle))
writeChan incomingChan (ConnectionTerminated (switchSockAddr clientHandle))
return ()
Just m -> do writeChan incomingChan (PeerMessage (switchSockAddr clientHandle) m)
enqIncoming clientHandle
let getIncoming = readChan incomingChan
let postOutgoing sockAddress msg =
withMVar addressToClientMap $ \dict ->
case Map.lookup sockAddress dict of
Just switchHandle -> sendToSwitch switchHandle msg
Nothing -> error ("handle disappeared before message " ++ show msg ++ " was sent.")
let acceptLoop =
forever (do (client,_) <- acceptSwitch server
modifyMVar_ addressToClientMap (return . Map.insert (switchSockAddr client) client)
writeChan incomingChan (ConnectionEstablished (switchSockAddr client))
forkIO (enqIncoming client)
)
forkIO acceptLoop
return (getIncoming, postOutgoing)