gameServer/ClientIO.hs
author unc0rr
Sun, 16 Aug 2009 11:56:10 +0000
changeset 2314 953771a06c64
parent 2296 19f2f76dc346
child 2348 b39d826e1ccd
permissions -rw-r--r--
Better fix

{-# LANGUAGE CPP, PatternSignatures #-}
module ClientIO where

#if defined(NEW_EXCEPTIONS)
import qualified Control.OldException as Exception
#else
import qualified Control.Exception as Exception
#endif
import Control.Concurrent.Chan
import Control.Monad
import System.IO
----------------
import CoreTypes

listenLoop :: Handle -> Int -> [String] -> Chan CoreMessage -> Int -> IO ()
listenLoop handle linesNumber buf chan clientID = do
	str <- hGetLine handle
	if (linesNumber > 50) || (length str > 450) then
		writeChan chan $ ClientMessage (clientID, ["QUIT", "Protocol violation"])
		else
		if str == "" then do
			writeChan chan $ ClientMessage (clientID, buf)
			listenLoop handle 0 [] chan clientID
			else
			listenLoop handle (linesNumber + 1) (buf ++ [str]) chan clientID

clientRecvLoop :: Handle -> Chan CoreMessage -> Int -> IO ()
clientRecvLoop handle chan clientID =
	listenLoop handle 0 [] chan clientID
		`catch` (\e -> (clientOff $ show e) >> return ())
	where clientOff msg = writeChan chan $ ClientMessage (clientID, ["QUIT", msg]) -- if the client disconnects, we perform as if it sent QUIT message

clientSendLoop :: Handle -> Chan CoreMessage -> Chan [String] -> Int -> IO()
clientSendLoop handle coreChan chan clientID = do
	answer <- readChan chan
	doClose <- Exception.handle
		(\(e :: Exception.Exception) -> if isQuit answer then return True else sendQuit e >> return False) $ do
		forM_ answer (\str -> hPutStrLn handle str)
		hPutStrLn handle ""
		hFlush handle
		return $ isQuit answer

	if doClose then
		Exception.handle (\(_ :: Exception.Exception) -> putStrLn "error on hClose") $ hClose handle
		else
		clientSendLoop handle coreChan chan clientID

	where
		sendQuit e = writeChan coreChan $ ClientMessage (clientID, ["QUIT", show e])
		isQuit ("BYE":xs) = True
		isQuit _ = False