gameServer/ClientIO.hs
author unc0rr
Sat, 09 Jun 2012 23:35:55 +0400
changeset 7212 ab60dbe8fd0c
parent 5989 23407ecb1826
child 7252 74a92f39703b
permissions -rw-r--r--
TestBaseballBat
Ignore whitespace changes - Everywhere: Within whitespace: At end of lines:
5077
7915668502a6 Some fixes. Can't reproduce ghosts now.
unc0rr
parents: 5059
diff changeset
     1
{-# LANGUAGE ScopedTypeVariables, OverloadedStrings, Rank2Types #-}
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
5032
813554ab76b8 Replaced bs2packs.
EJ <eivind.jahren@gmail.com>
parents: 5030
diff changeset
     5
import Control.Monad.State
1804
4e78ad846fb6 New game server:
unc0rr
parents:
diff changeset
     6
import Control.Concurrent.Chan
2867
9be6693c78cb - Unbreak support for client versions prior to 0.9.13-dev
unc0rr
parents: 2352
diff changeset
     7
import Control.Concurrent
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
     8
import Network
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
     9
import Network.Socket.ByteString
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
    10
import qualified Data.ByteString.Char8 as B
1804
4e78ad846fb6 New game server:
unc0rr
parents:
diff changeset
    11
----------------
4e78ad846fb6 New game server:
unc0rr
parents:
diff changeset
    12
import CoreTypes
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
    13
import RoomsAndClients
3458
11cd56019f00 Make some more protocol commands work
unc0rr
parents: 3435
diff changeset
    14
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
    15
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
    16
pDelim :: B.ByteString
5030
42746c5d4a80 Changed the standard show function to Text.Show.ByteString, and misc.
EJ <eivind.jahren@gmail.com>
parents: 5012
diff changeset
    17
pDelim = "\n\n"
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
    18
5059
68a5415ca8ea More creation of sender thread to the reciever thread
unc0rr
parents: 5037
diff changeset
    19
bs2Packets :: B.ByteString -> ([[B.ByteString]], B.ByteString)
5032
813554ab76b8 Replaced bs2packs.
EJ <eivind.jahren@gmail.com>
parents: 5030
diff changeset
    20
bs2Packets = runState takePacks
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
    21
5032
813554ab76b8 Replaced bs2packs.
EJ <eivind.jahren@gmail.com>
parents: 5030
diff changeset
    22
takePacks :: State B.ByteString [[B.ByteString]]
813554ab76b8 Replaced bs2packs.
EJ <eivind.jahren@gmail.com>
parents: 5030
diff changeset
    23
takePacks
813554ab76b8 Replaced bs2packs.
EJ <eivind.jahren@gmail.com>
parents: 5030
diff changeset
    24
  = do modify (until (not . B.isPrefixOf pDelim) (B.drop 2))
813554ab76b8 Replaced bs2packs.
EJ <eivind.jahren@gmail.com>
parents: 5030
diff changeset
    25
       packet <- state $ B.breakSubstring pDelim
813554ab76b8 Replaced bs2packs.
EJ <eivind.jahren@gmail.com>
parents: 5030
diff changeset
    26
       buf <- get
813554ab76b8 Replaced bs2packs.
EJ <eivind.jahren@gmail.com>
parents: 5030
diff changeset
    27
       if B.null buf then put packet >> return [] else
813554ab76b8 Replaced bs2packs.
EJ <eivind.jahren@gmail.com>
parents: 5030
diff changeset
    28
        if B.null packet then  return [] else
813554ab76b8 Replaced bs2packs.
EJ <eivind.jahren@gmail.com>
parents: 5030
diff changeset
    29
         do packets <- takePacks
813554ab76b8 Replaced bs2packs.
EJ <eivind.jahren@gmail.com>
parents: 5030
diff changeset
    30
            return (B.splitWith (== '\n') packet : packets)
3500
af8390d807d6 Use sockets instead of handles, use bytestrings instead of strings
unc0rr
parents: 3458
diff changeset
    31
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
listenLoop :: Socket -> Chan CoreMessage -> ClientIndex -> IO ()
5077
7915668502a6 Some fixes. Can't reproduce ghosts now.
unc0rr
parents: 5059
diff changeset
    33
listenLoop sock chan ci = recieveWithBufferLoop B.empty
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
    34
    where
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
    35
        recieveWithBufferLoop recvBuf = do
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
    36
            recvBS <- recv sock 4096
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
    37
            unless (B.null recvBS) $ do
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
    38
                let (packets, newrecvBuf) = bs2Packets $ B.append recvBuf recvBS
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
    39
                forM_ packets sendPacket
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
    40
                recieveWithBufferLoop newrecvBuf
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
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
    42
        sendPacket packet = writeChan chan $ ClientMessage (ci, packet)
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
    43
5077
7915668502a6 Some fixes. Can't reproduce ghosts now.
unc0rr
parents: 5059
diff changeset
    44
clientRecvLoop :: Socket -> Chan CoreMessage -> Chan [B.ByteString] -> ClientIndex -> (forall a. IO a -> IO a) -> IO ()
7915668502a6 Some fixes. Can't reproduce ghosts now.
unc0rr
parents: 5059
diff changeset
    45
clientRecvLoop s chan clChan ci restore =
5059
68a5415ca8ea More creation of sender thread to the reciever thread
unc0rr
parents: 5037
diff changeset
    46
    myThreadId >>=
5077
7915668502a6 Some fixes. Can't reproduce ghosts now.
unc0rr
parents: 5059
diff changeset
    47
    \t -> (restore $ forkIO (clientSendLoop s t clChan ci) >>
7915668502a6 Some fixes. Can't reproduce ghosts now.
unc0rr
parents: 5059
diff changeset
    48
        listenLoop s chan ci >> return "Connection closed")
5059
68a5415ca8ea More creation of sender thread to the reciever thread
unc0rr
parents: 5037
diff changeset
    49
        `Exception.catch` (\(e :: Exception.IOException) -> return . B.pack . show $ e)
5037
1edc06d2247c Fix ghost players (used Prelude.catch instead of Control.Exception.catch)
unc0rr
parents: 5032
diff changeset
    50
        `Exception.catch` (\(e :: ShutdownThreadException) -> return . B.pack . show $ e)
1edc06d2247c Fix ghost players (used Prelude.catch instead of Control.Exception.catch)
unc0rr
parents: 5032
diff changeset
    51
        >>= clientOff >> remove
4585
6e747aef012f Another approach for fixing listener thread issues, should finally get rid of all problems. Not tested.
unc0rr
parents: 4579
diff changeset
    52
    where
6e747aef012f Another approach for fixing listener thread issues, should finally get rid of all problems. Not tested.
unc0rr
parents: 4579
diff changeset
    53
        clientOff msg = writeChan chan $ ClientMessage (ci, ["QUIT", msg])
4996
76ef3d8bd78e Fix crash (accessing already deleted client record) by reverting to old client removing handling + throwTo
unc0rr
parents: 4982
diff changeset
    54
        remove = writeChan chan $ Remove ci
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
    55
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
    56
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
    57
5059
68a5415ca8ea More creation of sender thread to the reciever thread
unc0rr
parents: 5037
diff changeset
    58
clientSendLoop :: Socket -> ThreadId -> Chan [B.ByteString] -> ClientIndex -> IO ()
68a5415ca8ea More creation of sender thread to the reciever thread
unc0rr
parents: 5037
diff changeset
    59
clientSendLoop s tId chan ci = do
4568
f85243bf890e Ok. This should pull 0.9.14.1 server into default
nemo
parents: 4295
diff changeset
    60
    answer <- readChan chan
5989
23407ecb1826 My best guess for issue #285 is send thread being stuck at sendAll function, so I move client removing function before sendAll
unc0rr
parents: 5077
diff changeset
    61
23407ecb1826 My best guess for issue #285 is send thread being stuck at sendAll function, so I move client removing function before sendAll
unc0rr
parents: 5077
diff changeset
    62
    when (isQuit answer) $
23407ecb1826 My best guess for issue #285 is send thread being stuck at sendAll function, so I move client removing function before sendAll
unc0rr
parents: 5077
diff changeset
    63
        killReciever . B.unpack $ quitMessage answer
23407ecb1826 My best guess for issue #285 is send thread being stuck at sendAll function, so I move client removing function before sendAll
unc0rr
parents: 5077
diff changeset
    64
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
    65
    Exception.handle
5000
72d8fb26223d - Don't pretend client sent some message from sending thread (fixes crash when client is already deleted by recieveng thread)
unc0rr
parents: 4998
diff changeset
    66
        (\(e :: Exception.IOException) -> unless (isQuit answer) . killReciever $ show e) $
5030
42746c5d4a80 Changed the standard show function to Text.Show.ByteString, and misc.
EJ <eivind.jahren@gmail.com>
parents: 5012
diff changeset
    67
            sendAll s $ B.unlines answer `B.snoc` '\n'
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
    68
4932
f11d80bac7ed - Take into account hlint suggestions
unc0rr
parents: 4904
diff changeset
    69
    if isQuit answer then
4579
4e61c2a42121 Explicitly kill listening thread in try to prevent messages recieving bugs
unc0rr
parents: 4295
diff changeset
    70
        do
4585
6e747aef012f Another approach for fixing listener thread issues, should finally get rid of all problems. Not tested.
unc0rr
parents: 4579
diff changeset
    71
        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
    72
        else
5059
68a5415ca8ea More creation of sender thread to the reciever thread
unc0rr
parents: 5037
diff changeset
    73
        clientSendLoop s tId chan ci
1804
4e78ad846fb6 New game server:
unc0rr
parents:
diff changeset
    74
2867
9be6693c78cb - Unbreak support for client versions prior to 0.9.13-dev
unc0rr
parents: 2352
diff changeset
    75
    where
5000
72d8fb26223d - Don't pretend client sent some message from sending thread (fixes crash when client is already deleted by recieveng thread)
unc0rr
parents: 4998
diff changeset
    76
        killReciever = Exception.throwTo tId . ShutdownThreadException
5001
312f4dd41753 Better quit message
unc0rr
parents: 5000
diff changeset
    77
        quitMessage ["BYE"] = "bye"
312f4dd41753 Better quit message
unc0rr
parents: 5000
diff changeset
    78
        quitMessage ("BYE":msg:_) = msg
312f4dd41753 Better quit message
unc0rr
parents: 5000
diff changeset
    79
        quitMessage _ = error "quitMessage"
4932
f11d80bac7ed - Take into account hlint suggestions
unc0rr
parents: 4904
diff changeset
    80
        isQuit ("BYE":_) = True
2867
9be6693c78cb - Unbreak support for client versions prior to 0.9.13-dev
unc0rr
parents: 2352
diff changeset
    81
        isQuit _ = False