gameServer/ClientIO.hs
author szczur
Sun, 31 Oct 2010 21:17:17 -0400
changeset 4074 b73fd6ca06dd
parent 3947 709fdb89f76c
child 4242 5e3c5fe2cb14
permissions -rw-r--r--
polish update
Ignore whitespace changes - Everywhere: Within whitespace: At end of lines:
3500
af8390d807d6 Use sockets instead of handles, use bytestrings instead of strings
unc0rr
parents: 3458
diff changeset
     1
{-# LANGUAGE ScopedTypeVariables, OverloadedStrings #-}
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
3500
af8390d807d6 Use sockets instead of handles, use bytestrings instead of strings
unc0rr
parents: 3458
diff changeset
     9
import Network
af8390d807d6 Use sockets instead of handles, use bytestrings instead of strings
unc0rr
parents: 3458
diff changeset
    10
import Network.Socket.ByteString
af8390d807d6 Use sockets instead of handles, use bytestrings instead of strings
unc0rr
parents: 3458
diff changeset
    11
import qualified Data.ByteString.Char8 as B
1804
4e78ad846fb6 New game server:
unc0rr
parents:
diff changeset
    12
----------------
4e78ad846fb6 New game server:
unc0rr
parents:
diff changeset
    13
import CoreTypes
3435
4e4f88a7bdf2 Some more steps in refactoring
unc0rr
parents: 2954
diff changeset
    14
import RoomsAndClients
3500
af8390d807d6 Use sockets instead of handles, use bytestrings instead of strings
unc0rr
parents: 3458
diff changeset
    15
import Utils
3458
11cd56019f00 Make some more protocol commands work
unc0rr
parents: 3435
diff changeset
    16
1804
4e78ad846fb6 New game server:
unc0rr
parents:
diff changeset
    17
3500
af8390d807d6 Use sockets instead of handles, use bytestrings instead of strings
unc0rr
parents: 3458
diff changeset
    18
pDelim :: B.ByteString
af8390d807d6 Use sockets instead of handles, use bytestrings instead of strings
unc0rr
parents: 3458
diff changeset
    19
pDelim = B.pack "\n\n"
af8390d807d6 Use sockets instead of handles, use bytestrings instead of strings
unc0rr
parents: 3458
diff changeset
    20
af8390d807d6 Use sockets instead of handles, use bytestrings instead of strings
unc0rr
parents: 3458
diff changeset
    21
bs2Packets :: B.ByteString -> ([[B.ByteString]], B.ByteString)
af8390d807d6 Use sockets instead of handles, use bytestrings instead of strings
unc0rr
parents: 3458
diff changeset
    22
bs2Packets buf = unfoldrE extractPackets buf
af8390d807d6 Use sockets instead of handles, use bytestrings instead of strings
unc0rr
parents: 3458
diff changeset
    23
    where
af8390d807d6 Use sockets instead of handles, use bytestrings instead of strings
unc0rr
parents: 3458
diff changeset
    24
    extractPackets :: B.ByteString -> Either B.ByteString ([B.ByteString], B.ByteString)
af8390d807d6 Use sockets instead of handles, use bytestrings instead of strings
unc0rr
parents: 3458
diff changeset
    25
    extractPackets buf = 
af8390d807d6 Use sockets instead of handles, use bytestrings instead of strings
unc0rr
parents: 3458
diff changeset
    26
        let buf' = until (not . B.isPrefixOf pDelim) (B.drop 2) buf in
af8390d807d6 Use sockets instead of handles, use bytestrings instead of strings
unc0rr
parents: 3458
diff changeset
    27
            let (bsPacket, bufTail) = B.breakSubstring pDelim buf' in
af8390d807d6 Use sockets instead of handles, use bytestrings instead of strings
unc0rr
parents: 3458
diff changeset
    28
                if B.null bufTail then
af8390d807d6 Use sockets instead of handles, use bytestrings instead of strings
unc0rr
parents: 3458
diff changeset
    29
                    Left bsPacket
af8390d807d6 Use sockets instead of handles, use bytestrings instead of strings
unc0rr
parents: 3458
diff changeset
    30
                    else
af8390d807d6 Use sockets instead of handles, use bytestrings instead of strings
unc0rr
parents: 3458
diff changeset
    31
                    if B.null bsPacket then 
af8390d807d6 Use sockets instead of handles, use bytestrings instead of strings
unc0rr
parents: 3458
diff changeset
    32
                        Left bufTail
af8390d807d6 Use sockets instead of handles, use bytestrings instead of strings
unc0rr
parents: 3458
diff changeset
    33
                        else
af8390d807d6 Use sockets instead of handles, use bytestrings instead of strings
unc0rr
parents: 3458
diff changeset
    34
                        Right (B.splitWith (== '\n') bsPacket, bufTail)
3566
772a46ef8288 Properly handle client exit
unc0rr
parents: 3501
diff changeset
    35
3500
af8390d807d6 Use sockets instead of handles, use bytestrings instead of strings
unc0rr
parents: 3458
diff changeset
    36
af8390d807d6 Use sockets instead of handles, use bytestrings instead of strings
unc0rr
parents: 3458
diff changeset
    37
listenLoop :: Socket -> Chan CoreMessage -> ClientIndex -> IO ()
af8390d807d6 Use sockets instead of handles, use bytestrings instead of strings
unc0rr
parents: 3458
diff changeset
    38
listenLoop sock chan ci = recieveWithBufferLoop B.empty
af8390d807d6 Use sockets instead of handles, use bytestrings instead of strings
unc0rr
parents: 3458
diff changeset
    39
    where
af8390d807d6 Use sockets instead of handles, use bytestrings instead of strings
unc0rr
parents: 3458
diff changeset
    40
        recieveWithBufferLoop recvBuf = do
af8390d807d6 Use sockets instead of handles, use bytestrings instead of strings
unc0rr
parents: 3458
diff changeset
    41
            recvBS <- recv sock 4096
3501
a3159a410e5c Reimplement more core actions
unc0rr
parents: 3500
diff changeset
    42
--            putStrLn $ show sock ++ " got smth: " ++ (show $ B.length recvBS)
3500
af8390d807d6 Use sockets instead of handles, use bytestrings instead of strings
unc0rr
parents: 3458
diff changeset
    43
            unless (B.null recvBS) $ do
af8390d807d6 Use sockets instead of handles, use bytestrings instead of strings
unc0rr
parents: 3458
diff changeset
    44
                let (packets, newrecvBuf) = bs2Packets $ B.append recvBuf recvBS
af8390d807d6 Use sockets instead of handles, use bytestrings instead of strings
unc0rr
parents: 3458
diff changeset
    45
                forM_ packets sendPacket
af8390d807d6 Use sockets instead of handles, use bytestrings instead of strings
unc0rr
parents: 3458
diff changeset
    46
                recieveWithBufferLoop newrecvBuf
af8390d807d6 Use sockets instead of handles, use bytestrings instead of strings
unc0rr
parents: 3458
diff changeset
    47
af8390d807d6 Use sockets instead of handles, use bytestrings instead of strings
unc0rr
parents: 3458
diff changeset
    48
        sendPacket packet = writeChan chan $ ClientMessage (ci, packet)
af8390d807d6 Use sockets instead of handles, use bytestrings instead of strings
unc0rr
parents: 3458
diff changeset
    49
af8390d807d6 Use sockets instead of handles, use bytestrings instead of strings
unc0rr
parents: 3458
diff changeset
    50
af8390d807d6 Use sockets instead of handles, use bytestrings instead of strings
unc0rr
parents: 3458
diff changeset
    51
clientRecvLoop :: Socket -> Chan CoreMessage -> ClientIndex -> IO ()
af8390d807d6 Use sockets instead of handles, use bytestrings instead of strings
unc0rr
parents: 3458
diff changeset
    52
clientRecvLoop s chan ci = do
af8390d807d6 Use sockets instead of handles, use bytestrings instead of strings
unc0rr
parents: 3458
diff changeset
    53
    msg <- (listenLoop s chan ci >> return "Connection closed") `catch` (return . B.pack . show)
af8390d807d6 Use sockets instead of handles, use bytestrings instead of strings
unc0rr
parents: 3458
diff changeset
    54
    clientOff msg
3458
11cd56019f00 Make some more protocol commands work
unc0rr
parents: 3435
diff changeset
    55
    where 
3566
772a46ef8288 Properly handle client exit
unc0rr
parents: 3501
diff changeset
    56
        clientOff msg = mapM_ (writeChan chan) [ClientMessage (ci, ["QUIT", msg]), Remove ci]
3500
af8390d807d6 Use sockets instead of handles, use bytestrings instead of strings
unc0rr
parents: 3458
diff changeset
    57
1804
4e78ad846fb6 New game server:
unc0rr
parents:
diff changeset
    58
3500
af8390d807d6 Use sockets instead of handles, use bytestrings instead of strings
unc0rr
parents: 3458
diff changeset
    59
3947
709fdb89f76c Some screwing around in try to fix space leak. No luck yet.
unc0rr
parents: 3673
diff changeset
    60
clientSendLoop :: Socket -> Chan [B.ByteString] -> ClientIndex -> IO ()
709fdb89f76c Some screwing around in try to fix space leak. No luck yet.
unc0rr
parents: 3673
diff changeset
    61
clientSendLoop s chan ci = do
2867
9be6693c78cb - Unbreak support for client versions prior to 0.9.13-dev
unc0rr
parents: 2352
diff changeset
    62
    answer <- readChan chan
3673
45778b16b224 Some comments on the reason of the bug, leave bug not fixed yet
unc0rr
parents: 3671
diff changeset
    63
    Exception.handle
45778b16b224 Some comments on the reason of the bug, leave bug not fixed yet
unc0rr
parents: 3671
diff changeset
    64
        (\(e :: Exception.IOException) -> when (not $ isQuit answer) $ sendQuit e) $ do
3500
af8390d807d6 Use sockets instead of handles, use bytestrings instead of strings
unc0rr
parents: 3458
diff changeset
    65
            sendAll s $ (B.unlines answer) `B.append` (B.singleton '\n')
1804
4e78ad846fb6 New game server:
unc0rr
parents:
diff changeset
    66
3673
45778b16b224 Some comments on the reason of the bug, leave bug not fixed yet
unc0rr
parents: 3671
diff changeset
    67
    if (isQuit answer) then
3500
af8390d807d6 Use sockets instead of handles, use bytestrings instead of strings
unc0rr
parents: 3458
diff changeset
    68
        Exception.handle (\(_ :: Exception.IOException) -> putStrLn "error on sClose") $ sClose s
2867
9be6693c78cb - Unbreak support for client versions prior to 0.9.13-dev
unc0rr
parents: 2352
diff changeset
    69
        else
3947
709fdb89f76c Some screwing around in try to fix space leak. No luck yet.
unc0rr
parents: 3673
diff changeset
    70
        clientSendLoop s chan ci
1804
4e78ad846fb6 New game server:
unc0rr
parents:
diff changeset
    71
2867
9be6693c78cb - Unbreak support for client versions prior to 0.9.13-dev
unc0rr
parents: 2352
diff changeset
    72
    where
3673
45778b16b224 Some comments on the reason of the bug, leave bug not fixed yet
unc0rr
parents: 3671
diff changeset
    73
        --sendQuit e = writeChan coreChan $ ClientMessage (ci, ["QUIT", B.pack $ show e])
45778b16b224 Some comments on the reason of the bug, leave bug not fixed yet
unc0rr
parents: 3671
diff changeset
    74
        sendQuit e = putStrLn $ show e
2867
9be6693c78cb - Unbreak support for client versions prior to 0.9.13-dev
unc0rr
parents: 2352
diff changeset
    75
        isQuit ("BYE":xs) = True
9be6693c78cb - Unbreak support for client versions prior to 0.9.13-dev
unc0rr
parents: 2352
diff changeset
    76
        isQuit _ = False