gameServer/ClientIO.hs
author nemo
Sun, 19 Dec 2010 13:31:55 -0500
changeset 4568 f85243bf890e
parent 4295 1f5604cd99be
child 4570 fa19f0579083
permissions -rw-r--r--
Ok. This should pull 0.9.14.1 server into default
Ignore whitespace changes - Everywhere: Within whitespace: At end of lines:
4568
f85243bf890e Ok. This should pull 0.9.14.1 server into default
nemo
parents: 4295
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
4568
f85243bf890e Ok. This should pull 0.9.14.1 server into default
nemo
parents: 4295
diff changeset
     9
import qualified Data.ByteString.UTF8 as BUTF8
f85243bf890e Ok. This should pull 0.9.14.1 server into default
nemo
parents: 4295
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
3458
11cd56019f00 Make some more protocol commands work
unc0rr
parents: 3435
diff changeset
    13
4568
f85243bf890e Ok. This should pull 0.9.14.1 server into default
nemo
parents: 4295
diff changeset
    14
listenLoop :: Handle -> Int -> [String] -> Chan CoreMessage -> Int -> IO ()
f85243bf890e Ok. This should pull 0.9.14.1 server into default
nemo
parents: 4295
diff changeset
    15
listenLoop handle linesNumber buf chan clientID = do
f85243bf890e Ok. This should pull 0.9.14.1 server into default
nemo
parents: 4295
diff changeset
    16
    str <- liftM BUTF8.toString $ B.hGetLine handle
f85243bf890e Ok. This should pull 0.9.14.1 server into default
nemo
parents: 4295
diff changeset
    17
    if (linesNumber > 50) || (length str > 450) then
f85243bf890e Ok. This should pull 0.9.14.1 server into default
nemo
parents: 4295
diff changeset
    18
        writeChan chan $ ClientMessage (clientID, ["QUIT", "Protocol violation"])
f85243bf890e Ok. This should pull 0.9.14.1 server into default
nemo
parents: 4295
diff changeset
    19
        else
f85243bf890e Ok. This should pull 0.9.14.1 server into default
nemo
parents: 4295
diff changeset
    20
        if str == "" then do
f85243bf890e Ok. This should pull 0.9.14.1 server into default
nemo
parents: 4295
diff changeset
    21
            writeChan chan $ ClientMessage (clientID, buf)
f85243bf890e Ok. This should pull 0.9.14.1 server into default
nemo
parents: 4295
diff changeset
    22
            yield
f85243bf890e Ok. This should pull 0.9.14.1 server into default
nemo
parents: 4295
diff changeset
    23
            listenLoop handle 0 [] chan clientID
f85243bf890e Ok. This should pull 0.9.14.1 server into default
nemo
parents: 4295
diff changeset
    24
            else
f85243bf890e Ok. This should pull 0.9.14.1 server into default
nemo
parents: 4295
diff changeset
    25
            listenLoop handle (linesNumber + 1) (buf ++ [str]) chan clientID
3500
af8390d807d6 Use sockets instead of handles, use bytestrings instead of strings
unc0rr
parents: 3458
diff changeset
    26
4568
f85243bf890e Ok. This should pull 0.9.14.1 server into default
nemo
parents: 4295
diff changeset
    27
clientRecvLoop :: Handle -> Chan CoreMessage -> Int -> IO ()
f85243bf890e Ok. This should pull 0.9.14.1 server into default
nemo
parents: 4295
diff changeset
    28
clientRecvLoop handle chan clientID =
f85243bf890e Ok. This should pull 0.9.14.1 server into default
nemo
parents: 4295
diff changeset
    29
    listenLoop handle 0 [] chan clientID
f85243bf890e Ok. This should pull 0.9.14.1 server into default
nemo
parents: 4295
diff changeset
    30
        `catch` (\e -> clientOff (show e) >> return ())
f85243bf890e Ok. This should pull 0.9.14.1 server into default
nemo
parents: 4295
diff changeset
    31
    where clientOff msg = writeChan chan $ ClientMessage (clientID, ["QUIT", msg]) -- if the client disconnects, we perform as if it sent QUIT message
4295
1f5604cd99be This revision should, in theory, correctly merge 0.9.14 and tip, so that future merges of 0.9.14 should work properly
nemo
parents: 4242
diff changeset
    32
4568
f85243bf890e Ok. This should pull 0.9.14.1 server into default
nemo
parents: 4295
diff changeset
    33
clientSendLoop :: Handle -> Chan CoreMessage -> Chan [String] -> Int -> IO()
f85243bf890e Ok. This should pull 0.9.14.1 server into default
nemo
parents: 4295
diff changeset
    34
clientSendLoop handle coreChan chan clientID = do
f85243bf890e Ok. This should pull 0.9.14.1 server into default
nemo
parents: 4295
diff changeset
    35
    answer <- readChan chan
f85243bf890e Ok. This should pull 0.9.14.1 server into default
nemo
parents: 4295
diff changeset
    36
    doClose <- Exception.handle
f85243bf890e Ok. This should pull 0.9.14.1 server into default
nemo
parents: 4295
diff changeset
    37
        (\(e :: Exception.IOException) -> if isQuit answer then return True else sendQuit e >> return False) $ do
f85243bf890e Ok. This should pull 0.9.14.1 server into default
nemo
parents: 4295
diff changeset
    38
            B.hPutStrLn handle $ BUTF8.fromString $ unlines answer
f85243bf890e Ok. This should pull 0.9.14.1 server into default
nemo
parents: 4295
diff changeset
    39
            hFlush handle
f85243bf890e Ok. This should pull 0.9.14.1 server into default
nemo
parents: 4295
diff changeset
    40
            return $ isQuit answer
4295
1f5604cd99be This revision should, in theory, correctly merge 0.9.14 and tip, so that future merges of 0.9.14 should work properly
nemo
parents: 4242
diff changeset
    41
4568
f85243bf890e Ok. This should pull 0.9.14.1 server into default
nemo
parents: 4295
diff changeset
    42
    if doClose then
f85243bf890e Ok. This should pull 0.9.14.1 server into default
nemo
parents: 4295
diff changeset
    43
        Exception.handle (\(_ :: Exception.IOException) -> putStrLn "error on hClose") $ hClose handle
2867
9be6693c78cb - Unbreak support for client versions prior to 0.9.13-dev
unc0rr
parents: 2352
diff changeset
    44
        else
4568
f85243bf890e Ok. This should pull 0.9.14.1 server into default
nemo
parents: 4295
diff changeset
    45
        clientSendLoop handle coreChan chan clientID
1804
4e78ad846fb6 New game server:
unc0rr
parents:
diff changeset
    46
2867
9be6693c78cb - Unbreak support for client versions prior to 0.9.13-dev
unc0rr
parents: 2352
diff changeset
    47
    where
4568
f85243bf890e Ok. This should pull 0.9.14.1 server into default
nemo
parents: 4295
diff changeset
    48
        sendQuit e = writeChan coreChan $ ClientMessage (clientID, ["QUIT", show e])
2867
9be6693c78cb - Unbreak support for client versions prior to 0.9.13-dev
unc0rr
parents: 2352
diff changeset
    49
        isQuit ("BYE":xs) = True
9be6693c78cb - Unbreak support for client versions prior to 0.9.13-dev
unc0rr
parents: 2352
diff changeset
    50
        isQuit _ = False