gameServer/ClientIO.hs
author Wuzzy <Wuzzy2@mail.ru>
Mon, 07 Oct 2019 23:14:39 +0200
changeset 15446 1c342763102f
parent 13673 1aa5e884326a
child 15699 27eb5abd5058
permissions -rw-r--r--
Added tag 1.0.0-release for changeset 88770c206c31
Ignore whitespace changes - Everywhere: Within whitespace: At end of lines:
10460
8dcea9087d75 Added copyrights to gameServer directory
Gianfranco Costamagna <costamagnagianfranco@yahoo.it>
parents: 8454
diff changeset
     1
{-
8dcea9087d75 Added copyrights to gameServer directory
Gianfranco Costamagna <costamagnagianfranco@yahoo.it>
parents: 8454
diff changeset
     2
 * Hedgewars, a free turn based strategy game
11046
47a8c19ecb60 more copyright fixes
sheepluva
parents: 11027
diff changeset
     3
 * Copyright (c) 2004-2015 Andrey Korotaev <unC0Rr@gmail.com>
10460
8dcea9087d75 Added copyrights to gameServer directory
Gianfranco Costamagna <costamagnagianfranco@yahoo.it>
parents: 8454
diff changeset
     4
 *
8dcea9087d75 Added copyrights to gameServer directory
Gianfranco Costamagna <costamagnagianfranco@yahoo.it>
parents: 8454
diff changeset
     5
 * This program is free software; you can redistribute it and/or modify
8dcea9087d75 Added copyrights to gameServer directory
Gianfranco Costamagna <costamagnagianfranco@yahoo.it>
parents: 8454
diff changeset
     6
 * it under the terms of the GNU General Public License as published by
8dcea9087d75 Added copyrights to gameServer directory
Gianfranco Costamagna <costamagnagianfranco@yahoo.it>
parents: 8454
diff changeset
     7
 * the Free Software Foundation; version 2 of the License
8dcea9087d75 Added copyrights to gameServer directory
Gianfranco Costamagna <costamagnagianfranco@yahoo.it>
parents: 8454
diff changeset
     8
 *
8dcea9087d75 Added copyrights to gameServer directory
Gianfranco Costamagna <costamagnagianfranco@yahoo.it>
parents: 8454
diff changeset
     9
 * This program is distributed in the hope that it will be useful,
8dcea9087d75 Added copyrights to gameServer directory
Gianfranco Costamagna <costamagnagianfranco@yahoo.it>
parents: 8454
diff changeset
    10
 * but WITHOUT ANY WARRANTY; without even the implied warranty of
8dcea9087d75 Added copyrights to gameServer directory
Gianfranco Costamagna <costamagnagianfranco@yahoo.it>
parents: 8454
diff changeset
    11
 * MERCHANTABILITY or FITNESS FOR A PARTICULAR PURPOSE.  See the
8dcea9087d75 Added copyrights to gameServer directory
Gianfranco Costamagna <costamagnagianfranco@yahoo.it>
parents: 8454
diff changeset
    12
 * GNU General Public License for more details.
8dcea9087d75 Added copyrights to gameServer directory
Gianfranco Costamagna <costamagnagianfranco@yahoo.it>
parents: 8454
diff changeset
    13
 *
8dcea9087d75 Added copyrights to gameServer directory
Gianfranco Costamagna <costamagnagianfranco@yahoo.it>
parents: 8454
diff changeset
    14
 * You should have received a copy of the GNU General Public License
8dcea9087d75 Added copyrights to gameServer directory
Gianfranco Costamagna <costamagnagianfranco@yahoo.it>
parents: 8454
diff changeset
    15
 * along with this program; if not, write to the Free Software
8dcea9087d75 Added copyrights to gameServer directory
Gianfranco Costamagna <costamagnagianfranco@yahoo.it>
parents: 8454
diff changeset
    16
 * Foundation, Inc., 51 Franklin Street, Fifth Floor, Boston, MA 02110-1301 USA.
8dcea9087d75 Added copyrights to gameServer directory
Gianfranco Costamagna <costamagnagianfranco@yahoo.it>
parents: 8454
diff changeset
    17
 \-}
8dcea9087d75 Added copyrights to gameServer directory
Gianfranco Costamagna <costamagnagianfranco@yahoo.it>
parents: 8454
diff changeset
    18
5077
7915668502a6 Some fixes. Can't reproduce ghosts now.
unc0rr
parents: 5059
diff changeset
    19
{-# LANGUAGE ScopedTypeVariables, OverloadedStrings, Rank2Types #-}
1804
4e78ad846fb6 New game server:
unc0rr
parents:
diff changeset
    20
module ClientIO where
4e78ad846fb6 New game server:
unc0rr
parents:
diff changeset
    21
2296
19f2f76dc346 Patch for compiling with 6.10 (define NEW_EXCEPTIONS to do that)
unc0rr
parents: 2126
diff changeset
    22
import qualified Control.Exception as Exception
5032
813554ab76b8 Replaced bs2packs.
EJ <eivind.jahren@gmail.com>
parents: 5030
diff changeset
    23
import Control.Monad.State
1804
4e78ad846fb6 New game server:
unc0rr
parents:
diff changeset
    24
import Control.Concurrent.Chan
2867
9be6693c78cb - Unbreak support for client versions prior to 0.9.13-dev
unc0rr
parents: 2352
diff changeset
    25
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
    26
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
    27
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
    28
import qualified Data.ByteString.Char8 as B
1804
4e78ad846fb6 New game server:
unc0rr
parents:
diff changeset
    29
----------------
4e78ad846fb6 New game server:
unc0rr
parents:
diff changeset
    30
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
    31
import RoomsAndClients
3458
11cd56019f00 Make some more protocol commands work
unc0rr
parents: 3435
diff changeset
    32
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
    33
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
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
    35
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
    36
5059
68a5415ca8ea More creation of sender thread to the reciever thread
unc0rr
parents: 5037
diff changeset
    37
bs2Packets :: B.ByteString -> ([[B.ByteString]], B.ByteString)
5032
813554ab76b8 Replaced bs2packs.
EJ <eivind.jahren@gmail.com>
parents: 5030
diff changeset
    38
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
    39
5032
813554ab76b8 Replaced bs2packs.
EJ <eivind.jahren@gmail.com>
parents: 5030
diff changeset
    40
takePacks :: State B.ByteString [[B.ByteString]]
813554ab76b8 Replaced bs2packs.
EJ <eivind.jahren@gmail.com>
parents: 5030
diff changeset
    41
takePacks
813554ab76b8 Replaced bs2packs.
EJ <eivind.jahren@gmail.com>
parents: 5030
diff changeset
    42
  = do modify (until (not . B.isPrefixOf pDelim) (B.drop 2))
813554ab76b8 Replaced bs2packs.
EJ <eivind.jahren@gmail.com>
parents: 5030
diff changeset
    43
       packet <- state $ B.breakSubstring pDelim
813554ab76b8 Replaced bs2packs.
EJ <eivind.jahren@gmail.com>
parents: 5030
diff changeset
    44
       buf <- get
813554ab76b8 Replaced bs2packs.
EJ <eivind.jahren@gmail.com>
parents: 5030
diff changeset
    45
       if B.null buf then put packet >> return [] else
813554ab76b8 Replaced bs2packs.
EJ <eivind.jahren@gmail.com>
parents: 5030
diff changeset
    46
        if B.null packet then  return [] else
813554ab76b8 Replaced bs2packs.
EJ <eivind.jahren@gmail.com>
parents: 5030
diff changeset
    47
         do packets <- takePacks
813554ab76b8 Replaced bs2packs.
EJ <eivind.jahren@gmail.com>
parents: 5030
diff changeset
    48
            return (B.splitWith (== '\n') packet : packets)
3500
af8390d807d6 Use sockets instead of handles, use bytestrings instead of strings
unc0rr
parents: 3458
diff changeset
    49
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
    50
listenLoop :: Socket -> Chan CoreMessage -> ClientIndex -> IO ()
8371
0551b5c3de9a - Start work on checker
unc0rr
parents: 7388
diff changeset
    51
listenLoop sock chan ci = receiveWithBufferLoop 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
    52
    where
8371
0551b5c3de9a - Start work on checker
unc0rr
parents: 7388
diff changeset
    53
        receiveWithBufferLoop recvBuf = do
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
    54
            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
    55
            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
    56
                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
    57
                forM_ packets sendPacket
11027
ba585693e19d Don't allow too big messages from clients
unc0rr
parents: 10460
diff changeset
    58
                when (B.length newrecvBuf > 128 * 1024) $ sendPacket ["QUIT", "Protocol violation"]
8454
46b59c529bb1 Use Data.ByteString.copy on receive buffer to allow it free no longer used memory
unc0rr
parents: 8371
diff changeset
    59
                receiveWithBufferLoop $ B.copy newrecvBuf
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
    60
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
    61
        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
    62
5077
7915668502a6 Some fixes. Can't reproduce ghosts now.
unc0rr
parents: 5059
diff changeset
    63
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
    64
clientRecvLoop s chan clChan ci restore =
7321
57bd4f201401 - Try sending remove message in 'finally' as a last resort
unc0rr
parents: 7252
diff changeset
    65
    (myThreadId >>=
8371
0551b5c3de9a - Start work on checker
unc0rr
parents: 7388
diff changeset
    66
      (\t -> (restore $ forkIO (clientSendLoop s t clChan ci) >>
5077
7915668502a6 Some fixes. Can't reproduce ghosts now.
unc0rr
parents: 5059
diff changeset
    67
        listenLoop s chan ci >> return "Connection closed")
7321
57bd4f201401 - Try sending remove message in 'finally' as a last resort
unc0rr
parents: 7252
diff changeset
    68
        `Exception.catch` (\(e :: ShutdownThreadException) -> return . B.pack . show $ e)
5059
68a5415ca8ea More creation of sender thread to the reciever thread
unc0rr
parents: 5037
diff changeset
    69
        `Exception.catch` (\(e :: Exception.IOException) -> return . B.pack . show $ e)
7252
74a92f39703b Catch all types of exceptions in recv thread. Should probably help with ghosts problem, though I have no idea which else kind of exception could arise there.
unc0rr
parents: 5989
diff changeset
    70
        `Exception.catch` (\(e :: Exception.SomeException) -> return . B.pack . show $ e)
8371
0551b5c3de9a - Start work on checker
unc0rr
parents: 7388
diff changeset
    71
      )
7321
57bd4f201401 - Try sending remove message in 'finally' as a last resort
unc0rr
parents: 7252
diff changeset
    72
        >>= clientOff) `Exception.finally` remove
4585
6e747aef012f Another approach for fixing listener thread issues, should finally get rid of all problems. Not tested.
unc0rr
parents: 4579
diff changeset
    73
    where
6e747aef012f Another approach for fixing listener thread issues, should finally get rid of all problems. Not tested.
unc0rr
parents: 4579
diff changeset
    74
        clientOff msg = writeChan chan $ ClientMessage (ci, ["QUIT", msg])
7321
57bd4f201401 - Try sending remove message in 'finally' as a last resort
unc0rr
parents: 7252
diff changeset
    75
        remove = do
57bd4f201401 - Try sending remove message in 'finally' as a last resort
unc0rr
parents: 7252
diff changeset
    76
            clientOff "Client is in some weird state"
57bd4f201401 - Try sending remove message in 'finally' as a last resort
unc0rr
parents: 7252
diff changeset
    77
            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
    78
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
    79
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
    80
5059
68a5415ca8ea More creation of sender thread to the reciever thread
unc0rr
parents: 5037
diff changeset
    81
clientSendLoop :: Socket -> ThreadId -> Chan [B.ByteString] -> ClientIndex -> IO ()
68a5415ca8ea More creation of sender thread to the reciever thread
unc0rr
parents: 5037
diff changeset
    82
clientSendLoop s tId chan ci = do
4568
f85243bf890e Ok. This should pull 0.9.14.1 server into default
nemo
parents: 4295
diff changeset
    83
    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
    84
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
    85
    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
    86
        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
    87
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
    88
    Exception.handle
7388
92535bc7e928 Catch all exceptions in clientSendLoop. If there could something besides IOException be thrown there, that would explain ping timeouts server issue.
unc0rr
parents: 7321
diff changeset
    89
        (\(e :: Exception.SomeException) -> 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
    90
            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
    91
4932
f11d80bac7ed - Take into account hlint suggestions
unc0rr
parents: 4904
diff changeset
    92
    if isQuit answer then
7388
92535bc7e928 Catch all exceptions in clientSendLoop. If there could something besides IOException be thrown there, that would explain ping timeouts server issue.
unc0rr
parents: 7321
diff changeset
    93
        sClose s
2867
9be6693c78cb - Unbreak support for client versions prior to 0.9.13-dev
unc0rr
parents: 2352
diff changeset
    94
        else
5059
68a5415ca8ea More creation of sender thread to the reciever thread
unc0rr
parents: 5037
diff changeset
    95
        clientSendLoop s tId chan ci
1804
4e78ad846fb6 New game server:
unc0rr
parents:
diff changeset
    96
2867
9be6693c78cb - Unbreak support for client versions prior to 0.9.13-dev
unc0rr
parents: 2352
diff changeset
    97
    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
    98
        killReciever = Exception.throwTo tId . ShutdownThreadException
13673
1aa5e884326a Fix some string/translation inconsistencies in strings related to leaving
Wuzzy <Wuzzy2@mail.ru>
parents: 11046
diff changeset
    99
        -- intentionally not localized
5001
312f4dd41753 Better quit message
unc0rr
parents: 5000
diff changeset
   100
        quitMessage ["BYE"] = "bye"
312f4dd41753 Better quit message
unc0rr
parents: 5000
diff changeset
   101
        quitMessage ("BYE":msg:_) = msg
312f4dd41753 Better quit message
unc0rr
parents: 5000
diff changeset
   102
        quitMessage _ = error "quitMessage"
4932
f11d80bac7ed - Take into account hlint suggestions
unc0rr
parents: 4904
diff changeset
   103
        isQuit ("BYE":_) = True
2867
9be6693c78cb - Unbreak support for client versions prior to 0.9.13-dev
unc0rr
parents: 2352
diff changeset
   104
        isQuit _ = False