gameServer/ClientIO.hs
author nemo
Tue, 08 Sep 2009 19:44:49 +0000
changeset 2357 babe1a55e284
parent 2352 7eaf82cf0890
child 2867 9be6693c78cb
permissions -rw-r--r--
Add an empty weapon to avoid selection of weapons which aren't yet ready. Might all be useful to switch to amNothing in certain situations, like after using up all ropes, instead of bazooka.
Ignore whitespace changes - Everywhere: Within whitespace: At end of lines:
2348
b39d826e1ccd Drop support for ghc 6.8, use 6.10 instead
unc0rr
parents: 2296
diff changeset
     1
{-# LANGUAGE ScopedTypeVariables #-}
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
import qualified Control.Exception as Exception
1804
4e78ad846fb6 New game server:
unc0rr
parents:
diff changeset
     5
import Control.Concurrent.Chan
4e78ad846fb6 New game server:
unc0rr
parents:
diff changeset
     6
import Control.Monad
4e78ad846fb6 New game server:
unc0rr
parents:
diff changeset
     7
import System.IO
4e78ad846fb6 New game server:
unc0rr
parents:
diff changeset
     8
----------------
4e78ad846fb6 New game server:
unc0rr
parents:
diff changeset
     9
import CoreTypes
4e78ad846fb6 New game server:
unc0rr
parents:
diff changeset
    10
2001
d909152bdc21 - More verbose output
unc0rr
parents: 1804
diff changeset
    11
listenLoop :: Handle -> Int -> [String] -> Chan CoreMessage -> Int -> IO ()
d909152bdc21 - More verbose output
unc0rr
parents: 1804
diff changeset
    12
listenLoop handle linesNumber buf chan clientID = do
1804
4e78ad846fb6 New game server:
unc0rr
parents:
diff changeset
    13
	str <- hGetLine handle
2001
d909152bdc21 - More verbose output
unc0rr
parents: 1804
diff changeset
    14
	if (linesNumber > 50) || (length str > 450) then
d909152bdc21 - More verbose output
unc0rr
parents: 1804
diff changeset
    15
		writeChan chan $ ClientMessage (clientID, ["QUIT", "Protocol violation"])
1804
4e78ad846fb6 New game server:
unc0rr
parents:
diff changeset
    16
		else
2001
d909152bdc21 - More verbose output
unc0rr
parents: 1804
diff changeset
    17
		if str == "" then do
d909152bdc21 - More verbose output
unc0rr
parents: 1804
diff changeset
    18
			writeChan chan $ ClientMessage (clientID, buf)
d909152bdc21 - More verbose output
unc0rr
parents: 1804
diff changeset
    19
			listenLoop handle 0 [] chan clientID
d909152bdc21 - More verbose output
unc0rr
parents: 1804
diff changeset
    20
			else
d909152bdc21 - More verbose output
unc0rr
parents: 1804
diff changeset
    21
			listenLoop handle (linesNumber + 1) (buf ++ [str]) chan clientID
1804
4e78ad846fb6 New game server:
unc0rr
parents:
diff changeset
    22
4e78ad846fb6 New game server:
unc0rr
parents:
diff changeset
    23
clientRecvLoop :: Handle -> Chan CoreMessage -> Int -> IO ()
4e78ad846fb6 New game server:
unc0rr
parents:
diff changeset
    24
clientRecvLoop handle chan clientID =
2001
d909152bdc21 - More verbose output
unc0rr
parents: 1804
diff changeset
    25
	listenLoop handle 0 [] chan clientID
2352
7eaf82cf0890 Fixes suggested by hlint tool
unc0rr
parents: 2348
diff changeset
    26
		`catch` (\e -> clientOff (show e) >> return ())
1804
4e78ad846fb6 New game server:
unc0rr
parents:
diff changeset
    27
	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
    28
4e78ad846fb6 New game server:
unc0rr
parents:
diff changeset
    29
clientSendLoop :: Handle -> Chan CoreMessage -> Chan [String] -> Int -> IO()
4e78ad846fb6 New game server:
unc0rr
parents:
diff changeset
    30
clientSendLoop handle coreChan chan clientID = do
4e78ad846fb6 New game server:
unc0rr
parents:
diff changeset
    31
	answer <- readChan chan
2296
19f2f76dc346 Patch for compiling with 6.10 (define NEW_EXCEPTIONS to do that)
unc0rr
parents: 2126
diff changeset
    32
	doClose <- Exception.handle
2348
b39d826e1ccd Drop support for ghc 6.8, use 6.10 instead
unc0rr
parents: 2296
diff changeset
    33
		(\(e :: Exception.IOException) -> if isQuit answer then return True else sendQuit e >> return False) $ do
2352
7eaf82cf0890 Fixes suggested by hlint tool
unc0rr
parents: 2348
diff changeset
    34
		forM_ answer (hPutStrLn handle)
1804
4e78ad846fb6 New game server:
unc0rr
parents:
diff changeset
    35
		hPutStrLn handle ""
4e78ad846fb6 New game server:
unc0rr
parents:
diff changeset
    36
		hFlush handle
4e78ad846fb6 New game server:
unc0rr
parents:
diff changeset
    37
		return $ isQuit answer
4e78ad846fb6 New game server:
unc0rr
parents:
diff changeset
    38
4e78ad846fb6 New game server:
unc0rr
parents:
diff changeset
    39
	if doClose then
2348
b39d826e1ccd Drop support for ghc 6.8, use 6.10 instead
unc0rr
parents: 2296
diff changeset
    40
		Exception.handle (\(_ :: Exception.IOException) -> putStrLn "error on hClose") $ hClose handle
1804
4e78ad846fb6 New game server:
unc0rr
parents:
diff changeset
    41
		else
4e78ad846fb6 New game server:
unc0rr
parents:
diff changeset
    42
		clientSendLoop handle coreChan chan clientID
4e78ad846fb6 New game server:
unc0rr
parents:
diff changeset
    43
4e78ad846fb6 New game server:
unc0rr
parents:
diff changeset
    44
	where
4e78ad846fb6 New game server:
unc0rr
parents:
diff changeset
    45
		sendQuit e = writeChan coreChan $ ClientMessage (clientID, ["QUIT", show e])
2126
cb249fa8e3da - Prevent server from producing zombies
unc0rr
parents: 2001
diff changeset
    46
		isQuit ("BYE":xs) = True
cb249fa8e3da - Prevent server from producing zombies
unc0rr
parents: 2001
diff changeset
    47
		isQuit _ = False