gameServer/ClientIO.hs
author unc0rr
Sun, 30 Aug 2009 16:30:18 +0000
changeset 2339 f1bbcca1ae07
parent 2296 19f2f76dc346
child 2348 b39d826e1ccd
permissions -rw-r--r--
Prevent "free knocking" bug
Ignore whitespace changes - Everywhere: Within whitespace: At end of lines:
2296
19f2f76dc346 Patch for compiling with 6.10 (define NEW_EXCEPTIONS to do that)
unc0rr
parents: 2126
diff changeset
     1
{-# LANGUAGE CPP, PatternSignatures #-}
1804
4e78ad846fb6 New game server:
unc0rr
parents:
diff changeset
     2
module ClientIO where
4e78ad846fb6 New game server:
unc0rr
parents:
diff changeset
     3
2296
19f2f76dc346 Patch for compiling with 6.10 (define NEW_EXCEPTIONS to do that)
unc0rr
parents: 2126
diff changeset
     4
#if defined(NEW_EXCEPTIONS)
19f2f76dc346 Patch for compiling with 6.10 (define NEW_EXCEPTIONS to do that)
unc0rr
parents: 2126
diff changeset
     5
import qualified Control.OldException as Exception
19f2f76dc346 Patch for compiling with 6.10 (define NEW_EXCEPTIONS to do that)
unc0rr
parents: 2126
diff changeset
     6
#else
19f2f76dc346 Patch for compiling with 6.10 (define NEW_EXCEPTIONS to do that)
unc0rr
parents: 2126
diff changeset
     7
import qualified Control.Exception as Exception
19f2f76dc346 Patch for compiling with 6.10 (define NEW_EXCEPTIONS to do that)
unc0rr
parents: 2126
diff changeset
     8
#endif
1804
4e78ad846fb6 New game server:
unc0rr
parents:
diff changeset
     9
import Control.Concurrent.Chan
4e78ad846fb6 New game server:
unc0rr
parents:
diff changeset
    10
import Control.Monad
4e78ad846fb6 New game server:
unc0rr
parents:
diff changeset
    11
import System.IO
4e78ad846fb6 New game server:
unc0rr
parents:
diff changeset
    12
----------------
4e78ad846fb6 New game server:
unc0rr
parents:
diff changeset
    13
import CoreTypes
4e78ad846fb6 New game server:
unc0rr
parents:
diff changeset
    14
2001
d909152bdc21 - More verbose output
unc0rr
parents: 1804
diff changeset
    15
listenLoop :: Handle -> Int -> [String] -> Chan CoreMessage -> Int -> IO ()
d909152bdc21 - More verbose output
unc0rr
parents: 1804
diff changeset
    16
listenLoop handle linesNumber buf chan clientID = do
1804
4e78ad846fb6 New game server:
unc0rr
parents:
diff changeset
    17
	str <- hGetLine handle
2001
d909152bdc21 - More verbose output
unc0rr
parents: 1804
diff changeset
    18
	if (linesNumber > 50) || (length str > 450) then
d909152bdc21 - More verbose output
unc0rr
parents: 1804
diff changeset
    19
		writeChan chan $ ClientMessage (clientID, ["QUIT", "Protocol violation"])
1804
4e78ad846fb6 New game server:
unc0rr
parents:
diff changeset
    20
		else
2001
d909152bdc21 - More verbose output
unc0rr
parents: 1804
diff changeset
    21
		if str == "" then do
d909152bdc21 - More verbose output
unc0rr
parents: 1804
diff changeset
    22
			writeChan chan $ ClientMessage (clientID, buf)
d909152bdc21 - More verbose output
unc0rr
parents: 1804
diff changeset
    23
			listenLoop handle 0 [] chan clientID
d909152bdc21 - More verbose output
unc0rr
parents: 1804
diff changeset
    24
			else
d909152bdc21 - More verbose output
unc0rr
parents: 1804
diff changeset
    25
			listenLoop handle (linesNumber + 1) (buf ++ [str]) chan clientID
1804
4e78ad846fb6 New game server:
unc0rr
parents:
diff changeset
    26
4e78ad846fb6 New game server:
unc0rr
parents:
diff changeset
    27
clientRecvLoop :: Handle -> Chan CoreMessage -> Int -> IO ()
4e78ad846fb6 New game server:
unc0rr
parents:
diff changeset
    28
clientRecvLoop handle chan clientID =
2001
d909152bdc21 - More verbose output
unc0rr
parents: 1804
diff changeset
    29
	listenLoop handle 0 [] chan clientID
1804
4e78ad846fb6 New game server:
unc0rr
parents:
diff changeset
    30
		`catch` (\e -> (clientOff $ show e) >> return ())
4e78ad846fb6 New game server:
unc0rr
parents:
diff changeset
    31
	where clientOff msg = writeChan chan $ ClientMessage (clientID, ["QUIT", msg]) -- if the client disconnects, we perform as if it sent QUIT message
4e78ad846fb6 New game server:
unc0rr
parents:
diff changeset
    32
4e78ad846fb6 New game server:
unc0rr
parents:
diff changeset
    33
clientSendLoop :: Handle -> Chan CoreMessage -> Chan [String] -> Int -> IO()
4e78ad846fb6 New game server:
unc0rr
parents:
diff changeset
    34
clientSendLoop handle coreChan chan clientID = do
4e78ad846fb6 New game server:
unc0rr
parents:
diff changeset
    35
	answer <- readChan chan
2296
19f2f76dc346 Patch for compiling with 6.10 (define NEW_EXCEPTIONS to do that)
unc0rr
parents: 2126
diff changeset
    36
	doClose <- Exception.handle
19f2f76dc346 Patch for compiling with 6.10 (define NEW_EXCEPTIONS to do that)
unc0rr
parents: 2126
diff changeset
    37
		(\(e :: Exception.Exception) -> if isQuit answer then return True else sendQuit e >> return False) $ do
1804
4e78ad846fb6 New game server:
unc0rr
parents:
diff changeset
    38
		forM_ answer (\str -> hPutStrLn handle str)
4e78ad846fb6 New game server:
unc0rr
parents:
diff changeset
    39
		hPutStrLn handle ""
4e78ad846fb6 New game server:
unc0rr
parents:
diff changeset
    40
		hFlush handle
4e78ad846fb6 New game server:
unc0rr
parents:
diff changeset
    41
		return $ isQuit answer
4e78ad846fb6 New game server:
unc0rr
parents:
diff changeset
    42
4e78ad846fb6 New game server:
unc0rr
parents:
diff changeset
    43
	if doClose then
2296
19f2f76dc346 Patch for compiling with 6.10 (define NEW_EXCEPTIONS to do that)
unc0rr
parents: 2126
diff changeset
    44
		Exception.handle (\(_ :: Exception.Exception) -> putStrLn "error on hClose") $ hClose handle
1804
4e78ad846fb6 New game server:
unc0rr
parents:
diff changeset
    45
		else
4e78ad846fb6 New game server:
unc0rr
parents:
diff changeset
    46
		clientSendLoop handle coreChan chan clientID
4e78ad846fb6 New game server:
unc0rr
parents:
diff changeset
    47
4e78ad846fb6 New game server:
unc0rr
parents:
diff changeset
    48
	where
4e78ad846fb6 New game server:
unc0rr
parents:
diff changeset
    49
		sendQuit e = writeChan coreChan $ ClientMessage (clientID, ["QUIT", show e])
2126
cb249fa8e3da - Prevent server from producing zombies
unc0rr
parents: 2001
diff changeset
    50
		isQuit ("BYE":xs) = True
cb249fa8e3da - Prevent server from producing zombies
unc0rr
parents: 2001
diff changeset
    51
		isQuit _ = False