author | Xeli |
Tue, 05 Jul 2011 18:23:54 +0200 | |
branch | hedgeroid |
changeset 5395 | 5caae9d7e12e |
parent 5077 | 7915668502a6 |
child 5989 | 23407ecb1826 |
permissions | -rw-r--r-- |
5077 | 1 |
{-# LANGUAGE ScopedTypeVariables, OverloadedStrings, Rank2Types #-} |
1804 | 2 |
module ClientIO where |
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 | 5 |
import Control.Monad.State |
1804 | 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 | 11 |
---------------- |
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 | 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 | 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 | 22 |
takePacks :: State B.ByteString [[B.ByteString]] |
23 |
takePacks |
|
24 |
= do modify (until (not . B.isPrefixOf pDelim) (B.drop 2)) |
|
25 |
packet <- state $ B.breakSubstring pDelim |
|
26 |
buf <- get |
|
27 |
if B.null buf then put packet >> return [] else |
|
28 |
if B.null packet then return [] else |
|
29 |
do packets <- takePacks |
|
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 | 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 | 44 |
clientRecvLoop :: Socket -> Chan CoreMessage -> Chan [B.ByteString] -> ClientIndex -> (forall a. IO a -> IO a) -> IO () |
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 | 47 |
\t -> (restore $ forkIO (clientSendLoop s t clChan ci) >> |
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 | 60 |
answer <- readChan chan |
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
|
61 |
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
|
62 |
(\(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
|
63 |
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
|
64 |
|
4932 | 65 |
if isQuit answer then |
4579
4e61c2a42121
Explicitly kill listening thread in try to prevent messages recieving bugs
unc0rr
parents:
4295
diff
changeset
|
66 |
do |
4585
6e747aef012f
Another approach for fixing listener thread issues, should finally get rid of all problems. Not tested.
unc0rr
parents:
4579
diff
changeset
|
67 |
Exception.handle (\(_ :: Exception.IOException) -> putStrLn "error on sClose") $ sClose s |
5001 | 68 |
killReciever . B.unpack $ quitMessage answer |
2867
9be6693c78cb
- Unbreak support for client versions prior to 0.9.13-dev
unc0rr
parents:
2352
diff
changeset
|
69 |
else |
5059
68a5415ca8ea
More creation of sender thread to the reciever thread
unc0rr
parents:
5037
diff
changeset
|
70 |
clientSendLoop s tId chan ci |
1804 | 71 |
|
2867
9be6693c78cb
- Unbreak support for client versions prior to 0.9.13-dev
unc0rr
parents:
2352
diff
changeset
|
72 |
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
|
73 |
killReciever = Exception.throwTo tId . ShutdownThreadException |
5001 | 74 |
quitMessage ["BYE"] = "bye" |
75 |
quitMessage ("BYE":msg:_) = msg |
|
76 |
quitMessage _ = error "quitMessage" |
|
4932 | 77 |
isQuit ("BYE":_) = True |
2867
9be6693c78cb
- Unbreak support for client versions prior to 0.9.13-dev
unc0rr
parents:
2352
diff
changeset
|
78 |
isQuit _ = False |