module Nettle.Servers.MultiplexedTCPServer
(
muxedTCPServer,
MultiplexedProcess,
TCPMessage(..)
) where
import Prelude hiding (interact, catch)
import Nettle.Servers.TwoWayChannel
import Nettle.Servers.TCPServer
import Control.Concurrent
import Control.Exception
import Control.Monad
import qualified Data.Map as Map
import Data.Binary
type MultiplexedProcess a b = Process (TCPMessage a) (SockAddr, b) IOException
data TCPMessage a = ConnectionEstablished SockAddr
| ConnectionTerminated SockAddr IOException
| PeerMessage SockAddr a
deriving (Show,Eq)
muxedTCPServer :: Show a => ServerPortNumber -> TCPMessageDriver a b -> IO (MultiplexedProcess a b)
muxedTCPServer pstring driver = do
resultCh <- newChan2
peers <- tcpServer pstring driver
addrToChanMapVar <- newMVar Map.empty
forkIO $ sequence_ [ forkIO (multiplex addrToChanMapVar resultCh addr process) | (addr,process) <- peers ]
forkIO $ demultiplex addrToChanMapVar resultCh
let ch' = theOtherEnd2 resultCh
d <- newEmptyMVar
return (Process { readP = readChan2 ch',
tellP = writeChan2 ch',
whenDeadP = readMVar d })
where
multiplex addrToChanMapVar resultCh addr process =
do modifyMVar_ addrToChanMapVar (return . Map.insert addr process)
writeChan2 resultCh (ConnectionEstablished addr)
catch (forever (readP process >>= writeChan2 resultCh . PeerMessage addr))
(\e -> modifyMVar_ addrToChanMapVar (return . Map.delete addr) >>
writeChan2 resultCh (ConnectionTerminated addr e))
demultiplex addrToChanMapVar resultCh =
forever (readChan2 resultCh >>= \(addr, msg) -> withMVar addrToChanMapVar (lookupAndSend addr msg))
where lookupAndSend addr msg addrToChanMap =
case Map.lookup addr addrToChanMap of
Nothing -> return ()
Just process -> tellP process msg