gameServer/ClientIO.hs
author unc0rr
Thu, 05 Mar 2009 21:41:18 +0000
changeset 1863 705c01571196
parent 1804 4e78ad846fb6
child 2001 d909152bdc21
permissions -rw-r--r--
Utility icon
Ignore whitespace changes - Everywhere: Within whitespace: At end of lines:
1804
4e78ad846fb6 New game server:
unc0rr
parents:
diff changeset
     1
{-# LANGUAGE PatternSignatures #-}
4e78ad846fb6 New game server:
unc0rr
parents:
diff changeset
     2
module ClientIO where
4e78ad846fb6 New game server:
unc0rr
parents:
diff changeset
     3
4e78ad846fb6 New game server:
unc0rr
parents:
diff changeset
     4
import qualified Control.Exception
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
4e78ad846fb6 New game server:
unc0rr
parents:
diff changeset
    11
listenLoop :: Handle -> [String] -> Chan CoreMessage -> Int -> IO ()
4e78ad846fb6 New game server:
unc0rr
parents:
diff changeset
    12
listenLoop handle buf chan clientID = do
4e78ad846fb6 New game server:
unc0rr
parents:
diff changeset
    13
	str <- hGetLine handle
4e78ad846fb6 New game server:
unc0rr
parents:
diff changeset
    14
	if str == "" then do
4e78ad846fb6 New game server:
unc0rr
parents:
diff changeset
    15
		writeChan chan $ ClientMessage (clientID, buf)
4e78ad846fb6 New game server:
unc0rr
parents:
diff changeset
    16
		listenLoop handle [] chan clientID
4e78ad846fb6 New game server:
unc0rr
parents:
diff changeset
    17
		else
4e78ad846fb6 New game server:
unc0rr
parents:
diff changeset
    18
		listenLoop handle (buf ++ [str]) chan clientID
4e78ad846fb6 New game server:
unc0rr
parents:
diff changeset
    19
4e78ad846fb6 New game server:
unc0rr
parents:
diff changeset
    20
clientRecvLoop :: Handle -> Chan CoreMessage -> Int -> IO ()
4e78ad846fb6 New game server:
unc0rr
parents:
diff changeset
    21
clientRecvLoop handle chan clientID =
4e78ad846fb6 New game server:
unc0rr
parents:
diff changeset
    22
	listenLoop handle [] chan clientID
4e78ad846fb6 New game server:
unc0rr
parents:
diff changeset
    23
		`catch` (\e -> (clientOff $ show e) >> return ())
4e78ad846fb6 New game server:
unc0rr
parents:
diff changeset
    24
	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
    25
4e78ad846fb6 New game server:
unc0rr
parents:
diff changeset
    26
clientSendLoop :: Handle -> Chan CoreMessage -> Chan [String] -> Int -> IO()
4e78ad846fb6 New game server:
unc0rr
parents:
diff changeset
    27
clientSendLoop handle coreChan chan clientID = do
4e78ad846fb6 New game server:
unc0rr
parents:
diff changeset
    28
	answer <- readChan chan
4e78ad846fb6 New game server:
unc0rr
parents:
diff changeset
    29
	doClose <- Control.Exception.handle
4e78ad846fb6 New game server:
unc0rr
parents:
diff changeset
    30
		(\(e :: Control.Exception.Exception) -> if isQuit answer then return True else sendQuit e >> return False) $ do
4e78ad846fb6 New game server:
unc0rr
parents:
diff changeset
    31
		forM_ answer (\str -> hPutStrLn handle str)
4e78ad846fb6 New game server:
unc0rr
parents:
diff changeset
    32
		hPutStrLn handle ""
4e78ad846fb6 New game server:
unc0rr
parents:
diff changeset
    33
		hFlush handle
4e78ad846fb6 New game server:
unc0rr
parents:
diff changeset
    34
		return $ isQuit answer
4e78ad846fb6 New game server:
unc0rr
parents:
diff changeset
    35
4e78ad846fb6 New game server:
unc0rr
parents:
diff changeset
    36
	if doClose then
4e78ad846fb6 New game server:
unc0rr
parents:
diff changeset
    37
		Control.Exception.handle (\(_ :: Control.Exception.Exception) -> putStrLn "error on hClose") $ hClose handle
4e78ad846fb6 New game server:
unc0rr
parents:
diff changeset
    38
		else
4e78ad846fb6 New game server:
unc0rr
parents:
diff changeset
    39
		clientSendLoop handle coreChan chan clientID
4e78ad846fb6 New game server:
unc0rr
parents:
diff changeset
    40
4e78ad846fb6 New game server:
unc0rr
parents:
diff changeset
    41
	where
4e78ad846fb6 New game server:
unc0rr
parents:
diff changeset
    42
		sendQuit e = writeChan coreChan $ ClientMessage (clientID, ["QUIT", show e])
4e78ad846fb6 New game server:
unc0rr
parents:
diff changeset
    43
		isQuit answer = head answer == "BYE"