module Nettle.Servers.MessengerServer
(
Message
, messengerServer
, messengerClient
) where
import Data.Binary
import Data.Binary.Put
import Data.Binary.Get
import qualified Data.ByteString.Lazy.Char8 as B
import Control.Concurrent
import Nettle.Servers.TwoWayChannel
import Control.Exception (finally, handle, throwIO, Exception, handle)
import Data.Typeable
import Network
import Network.Socket
import Control.Monad (forever, when, unless, liftM, replicateM)
import System.IO
import System.IO.Error (IOError, isEOFError, mkIOError, eofErrorType)
type Message = String
sendMessage hdl message =
let writer = do putWord16be $ fromInteger $ toInteger $ length message
mapM_ put message
in B.hPut hdl $ runPut writer
receiveMessage hdl =
do isEOF <- hIsEOF hdl
when isEOF $ throwIO $ mkIOError eofErrorType "End of stream" (Just hdl) Nothing
headerBytes <- B.hGet hdl 2
let bodyLen = fromInteger $ toInteger (decode headerBytes :: Word16)
replicateM bodyLen $ hGetChar hdl
handleMessage addr hdl chan =
do message <- receiveMessage hdl
writeChan chan (addr, message)
trivialHandler :: IOError -> IO ()
trivialHandler e = print e >> return ()
handleClient hdl addr chan =
handle trivialHandler $
finally (sequence_ $ repeat $ handleMessage addr hdl chan)
(hClose hdl)
acceptConnection sock chan =
do (sock', addr) <- Network.Socket.accept sock
hdl <- socketToHandle sock' ReadWriteMode
hSetBuffering hdl NoBuffering
forkIO $ handleClient hdl addr chan
messengerServer :: PortID -> IO (Chan (SockAddr, Message))
messengerServer port =
do sock <- listenOn port
chan <- newChan
forkIO $ finally (forever $ acceptConnection sock chan) (sClose sock)
return chan
data DeadException = DeadException
deriving (Typeable, Show)
instance Exception DeadException
messengerClient :: HostName -> PortID -> (Chan2 (Maybe Message) (Maybe Message) () -> IO ()) -> IO ()
messengerClient host port client =
do
hdl <- connectTo host port
chan <- newChan2
forkIO $ client chan >> kill chan ()
forkIO $ whenDead chan >> writeChan2 chan Nothing
handleMessage hdl $ theOtherEnd2 chan
hClose hdl
where handleMessage hdl ch = do message <- readChan2 ch
case message of
Just msg -> do sendMessage hdl msg
handleMessage hdl ch
Nothing -> return ()