author | unc0rr |
Mon, 01 May 2017 13:59:24 +0300 | |
branch | 0.9.22 |
changeset 12406 | 7342f5020691 |
parent 11046 | 47a8c19ecb60 |
child 13678 | 1aa5e884326a |
permissions | -rw-r--r-- |
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 | 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 | 19 |
{-# LANGUAGE ScopedTypeVariables, OverloadedStrings, Rank2Types #-} |
1804 | 20 |
module ClientIO where |
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 | 23 |
import Control.Monad.State |
1804 | 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 | 29 |
---------------- |
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 | 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 | 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 | 40 |
takePacks :: State B.ByteString [[B.ByteString]] |
41 |
takePacks |
|
42 |
= do modify (until (not . B.isPrefixOf pDelim) (B.drop 2)) |
|
43 |
packet <- state $ B.breakSubstring pDelim |
|
44 |
buf <- get |
|
45 |
if B.null buf then put packet >> return [] else |
|
46 |
if B.null packet then return [] else |
|
47 |
do packets <- takePacks |
|
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 | 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 | 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 | 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 | 63 |
clientRecvLoop :: Socket -> Chan CoreMessage -> Chan [B.ByteString] -> ClientIndex -> (forall a. IO a -> IO a) -> IO () |
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 | 66 |
(\t -> (restore $ forkIO (clientSendLoop s t clChan ci) >> |
5077 | 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 | 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 | 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 | 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 | 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 |
5001 | 99 |
quitMessage ["BYE"] = "bye" |
100 |
quitMessage ("BYE":msg:_) = msg |
|
101 |
quitMessage _ = error "quitMessage" |
|
4932 | 102 |
isQuit ("BYE":_) = True |
2867
9be6693c78cb
- Unbreak support for client versions prior to 0.9.13-dev
unc0rr
parents:
2352
diff
changeset
|
103 |
isQuit _ = False |