1
2
3
4
5
6
7
8
9
10
11
12
13
14
15
16
17
18
19
20
21
22
23
24
25
26
27
28
29
30
31
32
33
34
35
36
37
38
39
40
41
42
43
44
45
46
47
48
49
50
51
52
53
54
55
56
57
58
59
60
61
62
63
64
65
66
67
68
69
70
71
72
73
74
75
76
77
78
79
80
81
82
83
84
85
86
87
88
89
90
91
92
93
94
95
96
97
98
99
100
101
102
103
104
105
|
{-
* Hedgewars, a free turn based strategy game
* Copyright (c) 2004-2015 Andrey Korotaev <unC0Rr@gmail.com>
*
* This program is free software; you can redistribute it and/or modify
* it under the terms of the GNU General Public License as published by
* the Free Software Foundation; version 2 of the License
*
* This program is distributed in the hope that it will be useful,
* but WITHOUT ANY WARRANTY; without even the implied warranty of
* MERCHANTABILITY or FITNESS FOR A PARTICULAR PURPOSE. See the
* GNU General Public License for more details.
*
* You should have received a copy of the GNU General Public License
* along with this program; if not, write to the Free Software
* Foundation, Inc., 51 Franklin Street, Fifth Floor, Boston, MA 02110-1301 USA.
\-}
{-# LANGUAGE ScopedTypeVariables, OverloadedStrings, Rank2Types #-}
module ClientIO where
import qualified Control.Exception as Exception
import Control.Monad
import Control.Monad.State
import Control.Concurrent.Chan
import Control.Concurrent
import Network.Socket hiding (recv)
import Network.Socket.ByteString
import qualified Data.ByteString.Char8 as B
----------------
import CoreTypes
import RoomsAndClients
pDelim :: B.ByteString
pDelim = "\n\n"
bs2Packets :: B.ByteString -> ([[B.ByteString]], B.ByteString)
bs2Packets = runState takePacks
takePacks :: State B.ByteString [[B.ByteString]]
takePacks
= do modify (until (not . B.isPrefixOf pDelim) (B.drop 2))
packet <- state $ B.breakSubstring pDelim
buf <- get
if B.null buf then put packet >> return [] else
if B.null packet then return [] else
do packets <- takePacks
return (B.splitWith (== '\n') packet : packets)
listenLoop :: Socket -> Chan CoreMessage -> ClientIndex -> IO ()
listenLoop sock chan ci = receiveWithBufferLoop B.empty
where
receiveWithBufferLoop recvBuf = do
recvBS <- recv sock 4096
unless (B.null recvBS) $ do
let (packets, newrecvBuf) = bs2Packets $ B.append recvBuf recvBS
forM_ packets sendPacket
when (B.length newrecvBuf > 128 * 1024) $ sendPacket ["QUIT", "Protocol violation"]
receiveWithBufferLoop $ B.copy newrecvBuf
sendPacket packet = writeChan chan $ ClientMessage (ci, packet)
clientRecvLoop :: Socket -> Chan CoreMessage -> Chan [B.ByteString] -> ClientIndex -> (forall a. IO a -> IO a) -> IO ()
clientRecvLoop s chan clChan ci restore =
(myThreadId >>=
(\t -> (restore $ forkIO (clientSendLoop s t clChan ci) >>
listenLoop s chan ci >> return "Connection closed")
`Exception.catch` (\(e :: ShutdownThreadException) -> return . B.pack . show $ e)
`Exception.catch` (\(e :: Exception.IOException) -> return . B.pack . show $ e)
`Exception.catch` (\(e :: Exception.SomeException) -> return . B.pack . show $ e)
)
>>= clientOff) `Exception.finally` remove
where
clientOff msg = writeChan chan $ ClientMessage (ci, ["QUIT", msg])
remove = do
clientOff "Client is in some weird state"
writeChan chan $ Remove ci
clientSendLoop :: Socket -> ThreadId -> Chan [B.ByteString] -> ClientIndex -> IO ()
clientSendLoop s tId chan ci = do
answer <- readChan chan
when (isQuit answer) $
killReciever . B.unpack $ quitMessage answer
Exception.handle
(\(e :: Exception.SomeException) -> unless (isQuit answer) . killReciever $ show e) $
sendAll s $ B.unlines answer `B.snoc` '\n'
if isQuit answer then
close s
else
clientSendLoop s tId chan ci
where
killReciever = Exception.throwTo tId . ShutdownThreadException
-- intentionally not localized
quitMessage ["BYE"] = "bye"
quitMessage ("BYE":msg:_) = msg
quitMessage _ = error "quitMessage"
isQuit ("BYE":_) = True
isQuit _ = False
|
