gameServer/ClientIO.hs
author unc0rr
Mon, 10 May 2010 17:48:06 +0000
changeset 3458 11cd56019f00
parent 3435 4e4f88a7bdf2
child 3500 af8390d807d6
permissions -rw-r--r--
Make some more protocol commands work
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
2867
9be6693c78cb - Unbreak support for client versions prior to 0.9.13-dev
unc0rr
parents: 2352
diff changeset
     6
import Control.Concurrent
1804
4e78ad846fb6 New game server:
unc0rr
parents:
diff changeset
     7
import Control.Monad
4e78ad846fb6 New game server:
unc0rr
parents:
diff changeset
     8
import System.IO
2952
18fada739b55 - Convert strings from utf-8 on recieve, and back to utf-8 when send them
unc0rr
parents: 2867
diff changeset
     9
import qualified Data.ByteString.UTF8 as BUTF8
18fada739b55 - Convert strings from utf-8 on recieve, and back to utf-8 when send them
unc0rr
parents: 2867
diff changeset
    10
import qualified Data.ByteString as B
1804
4e78ad846fb6 New game server:
unc0rr
parents:
diff changeset
    11
----------------
4e78ad846fb6 New game server:
unc0rr
parents:
diff changeset
    12
import CoreTypes
3435
4e4f88a7bdf2 Some more steps in refactoring
unc0rr
parents: 2954
diff changeset
    13
import RoomsAndClients
1804
4e78ad846fb6 New game server:
unc0rr
parents:
diff changeset
    14
3435
4e4f88a7bdf2 Some more steps in refactoring
unc0rr
parents: 2954
diff changeset
    15
listenLoop :: Handle -> Int -> [String] -> Chan CoreMessage -> ClientIndex -> IO ()
2001
d909152bdc21 - More verbose output
unc0rr
parents: 1804
diff changeset
    16
listenLoop handle linesNumber buf chan clientID = do
3458
11cd56019f00 Make some more protocol commands work
unc0rr
parents: 3435
diff changeset
    17
    putStrLn $ show handle ++ show buf ++ show clientID
2952
18fada739b55 - Convert strings from utf-8 on recieve, and back to utf-8 when send them
unc0rr
parents: 2867
diff changeset
    18
    str <- liftM BUTF8.toString $ B.hGetLine handle
2867
9be6693c78cb - Unbreak support for client versions prior to 0.9.13-dev
unc0rr
parents: 2352
diff changeset
    19
    if (linesNumber > 50) || (length str > 450) then
3458
11cd56019f00 Make some more protocol commands work
unc0rr
parents: 3435
diff changeset
    20
           protocolViolationMsg >> freeClient
2867
9be6693c78cb - Unbreak support for client versions prior to 0.9.13-dev
unc0rr
parents: 2352
diff changeset
    21
        else
9be6693c78cb - Unbreak support for client versions prior to 0.9.13-dev
unc0rr
parents: 2352
diff changeset
    22
        if str == "" then do
3458
11cd56019f00 Make some more protocol commands work
unc0rr
parents: 3435
diff changeset
    23
            writeChan chan $ ClientMessage (clientID, reverse buf)
2867
9be6693c78cb - Unbreak support for client versions prior to 0.9.13-dev
unc0rr
parents: 2352
diff changeset
    24
            yield
9be6693c78cb - Unbreak support for client versions prior to 0.9.13-dev
unc0rr
parents: 2352
diff changeset
    25
            listenLoop handle 0 [] chan clientID
9be6693c78cb - Unbreak support for client versions prior to 0.9.13-dev
unc0rr
parents: 2352
diff changeset
    26
            else
3458
11cd56019f00 Make some more protocol commands work
unc0rr
parents: 3435
diff changeset
    27
            listenLoop handle (linesNumber + 1) (str : buf) chan clientID
11cd56019f00 Make some more protocol commands work
unc0rr
parents: 3435
diff changeset
    28
    where 
11cd56019f00 Make some more protocol commands work
unc0rr
parents: 3435
diff changeset
    29
        protocolViolationMsg = writeChan chan $ ClientMessage (clientID, ["QUIT", "Protocol violation"])
11cd56019f00 Make some more protocol commands work
unc0rr
parents: 3435
diff changeset
    30
        freeClient = writeChan chan $ FreeClient clientID
11cd56019f00 Make some more protocol commands work
unc0rr
parents: 3435
diff changeset
    31
1804
4e78ad846fb6 New game server:
unc0rr
parents:
diff changeset
    32
3435
4e4f88a7bdf2 Some more steps in refactoring
unc0rr
parents: 2954
diff changeset
    33
clientRecvLoop :: Handle -> Chan CoreMessage -> ClientIndex -> IO ()
1804
4e78ad846fb6 New game server:
unc0rr
parents:
diff changeset
    34
clientRecvLoop handle chan clientID =
2867
9be6693c78cb - Unbreak support for client versions prior to 0.9.13-dev
unc0rr
parents: 2352
diff changeset
    35
    listenLoop handle 0 [] chan clientID
3458
11cd56019f00 Make some more protocol commands work
unc0rr
parents: 3435
diff changeset
    36
        `catch` (\e -> clientOff (show e) >> freeClient >> return ())
11cd56019f00 Make some more protocol commands work
unc0rr
parents: 3435
diff changeset
    37
    where 
11cd56019f00 Make some more protocol commands work
unc0rr
parents: 3435
diff changeset
    38
        clientOff msg = writeChan chan $ ClientMessage (clientID, ["QUIT", msg]) -- if the client disconnects, we perform as if it sent QUIT message
11cd56019f00 Make some more protocol commands work
unc0rr
parents: 3435
diff changeset
    39
        freeClient = writeChan chan $ FreeClient clientID
1804
4e78ad846fb6 New game server:
unc0rr
parents:
diff changeset
    40
3435
4e4f88a7bdf2 Some more steps in refactoring
unc0rr
parents: 2954
diff changeset
    41
clientSendLoop :: Handle -> Chan CoreMessage -> Chan [String] -> ClientIndex -> IO()
1804
4e78ad846fb6 New game server:
unc0rr
parents:
diff changeset
    42
clientSendLoop handle coreChan chan clientID = do
2867
9be6693c78cb - Unbreak support for client versions prior to 0.9.13-dev
unc0rr
parents: 2352
diff changeset
    43
    answer <- readChan chan
9be6693c78cb - Unbreak support for client versions prior to 0.9.13-dev
unc0rr
parents: 2352
diff changeset
    44
    doClose <- Exception.handle
9be6693c78cb - Unbreak support for client versions prior to 0.9.13-dev
unc0rr
parents: 2352
diff changeset
    45
        (\(e :: Exception.IOException) -> if isQuit answer then return True else sendQuit e >> return False) $ do
2954
55d272e34f9a Fix sending routine
unc0rr
parents: 2952
diff changeset
    46
            B.hPutStrLn handle $ BUTF8.fromString $ unlines answer
55d272e34f9a Fix sending routine
unc0rr
parents: 2952
diff changeset
    47
            hFlush handle
55d272e34f9a Fix sending routine
unc0rr
parents: 2952
diff changeset
    48
            return $ isQuit answer
1804
4e78ad846fb6 New game server:
unc0rr
parents:
diff changeset
    49
2867
9be6693c78cb - Unbreak support for client versions prior to 0.9.13-dev
unc0rr
parents: 2352
diff changeset
    50
    if doClose then
9be6693c78cb - Unbreak support for client versions prior to 0.9.13-dev
unc0rr
parents: 2352
diff changeset
    51
        Exception.handle (\(_ :: Exception.IOException) -> putStrLn "error on hClose") $ hClose handle
9be6693c78cb - Unbreak support for client versions prior to 0.9.13-dev
unc0rr
parents: 2352
diff changeset
    52
        else
9be6693c78cb - Unbreak support for client versions prior to 0.9.13-dev
unc0rr
parents: 2352
diff changeset
    53
        clientSendLoop handle coreChan chan clientID
1804
4e78ad846fb6 New game server:
unc0rr
parents:
diff changeset
    54
2867
9be6693c78cb - Unbreak support for client versions prior to 0.9.13-dev
unc0rr
parents: 2352
diff changeset
    55
    where
9be6693c78cb - Unbreak support for client versions prior to 0.9.13-dev
unc0rr
parents: 2352
diff changeset
    56
        sendQuit e = writeChan coreChan $ ClientMessage (clientID, ["QUIT", show e])
9be6693c78cb - Unbreak support for client versions prior to 0.9.13-dev
unc0rr
parents: 2352
diff changeset
    57
        isQuit ("BYE":xs) = True
9be6693c78cb - Unbreak support for client versions prior to 0.9.13-dev
unc0rr
parents: 2352
diff changeset
    58
        isQuit _ = False