author | Colin Rice (clr_) |
Wed, 23 Mar 2011 16:32:24 +0100 | |
changeset 5044 | 6e8da75e5f5e |
parent 5037 | 1edc06d2247c |
child 5059 | 68a5415ca8ea |
permissions | -rw-r--r-- |
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
|
1 |
{-# LANGUAGE ScopedTypeVariables, OverloadedStrings #-} |
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 |
1804 | 8 |
import Control.Monad |
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
|
9 |
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
|
10 |
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
|
11 |
import qualified Data.ByteString.Char8 as B |
1804 | 12 |
---------------- |
13 |
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
|
14 |
import RoomsAndClients |
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 |
import Utils |
3458 | 16 |
|
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
|
17 |
|
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 |
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
|
19 |
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
|
20 |
|
5032 | 21 |
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
|
22 |
|
5032 | 23 |
takePacks :: State B.ByteString [[B.ByteString]] |
24 |
takePacks |
|
25 |
= do modify (until (not . B.isPrefixOf pDelim) (B.drop 2)) |
|
26 |
packet <- state $ B.breakSubstring pDelim |
|
27 |
buf <- get |
|
28 |
if B.null buf then put packet >> return [] else |
|
29 |
if B.null packet then return [] else |
|
30 |
do packets <- takePacks |
|
31 |
return (B.splitWith (== '\n') packet : packets) |
|
3500
af8390d807d6
Use sockets instead of handles, use bytestrings instead of strings
unc0rr
parents:
3458
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 |
listenLoop :: Socket -> Chan CoreMessage -> ClientIndex -> IO () |
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 |
listenLoop sock chan ci = recieveWithBufferLoop B.empty |
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 |
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
|
36 |
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
|
37 |
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
|
38 |
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
|
39 |
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
|
40 |
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
|
41 |
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
|
42 |
|
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 |
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
|
44 |
|
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
|
45 |
clientRecvLoop :: Socket -> Chan CoreMessage -> ClientIndex -> IO () |
5011 | 46 |
clientRecvLoop s chan ci = |
5037
1edc06d2247c
Fix ghost players (used Prelude.catch instead of Control.Exception.catch)
unc0rr
parents:
5032
diff
changeset
|
47 |
(listenLoop s chan ci >> return "Connection closed") |
1edc06d2247c
Fix ghost players (used Prelude.catch instead of Control.Exception.catch)
unc0rr
parents:
5032
diff
changeset
|
48 |
`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
|
49 |
`Exception.catch` (\(e :: Exception.IOException) -> return . B.pack . show $ e) |
1edc06d2247c
Fix ghost players (used Prelude.catch instead of Control.Exception.catch)
unc0rr
parents:
5032
diff
changeset
|
50 |
>>= 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
|
51 |
where |
6e747aef012f
Another approach for fixing listener thread issues, should finally get rid of all problems. Not tested.
unc0rr
parents:
4579
diff
changeset
|
52 |
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
|
53 |
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
|
54 |
|
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 |
|
4585
6e747aef012f
Another approach for fixing listener thread issues, should finally get rid of all problems. Not tested.
unc0rr
parents:
4579
diff
changeset
|
57 |
clientSendLoop :: Socket -> ThreadId -> Chan CoreMessage -> Chan [B.ByteString] -> ClientIndex -> IO () |
4932 | 58 |
clientSendLoop s tId cChan chan ci = do |
4568 | 59 |
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
|
60 |
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
|
61 |
(\(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
|
62 |
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
|
63 |
|
4932 | 64 |
if isQuit answer then |
4579
4e61c2a42121
Explicitly kill listening thread in try to prevent messages recieving bugs
unc0rr
parents:
4295
diff
changeset
|
65 |
do |
4585
6e747aef012f
Another approach for fixing listener thread issues, should finally get rid of all problems. Not tested.
unc0rr
parents:
4579
diff
changeset
|
66 |
Exception.handle (\(_ :: Exception.IOException) -> putStrLn "error on sClose") $ sClose s |
5001 | 67 |
killReciever . B.unpack $ quitMessage answer |
2867
9be6693c78cb
- Unbreak support for client versions prior to 0.9.13-dev
unc0rr
parents:
2352
diff
changeset
|
68 |
else |
4932 | 69 |
clientSendLoop s tId cChan chan ci |
1804 | 70 |
|
2867
9be6693c78cb
- Unbreak support for client versions prior to 0.9.13-dev
unc0rr
parents:
2352
diff
changeset
|
71 |
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
|
72 |
killReciever = Exception.throwTo tId . ShutdownThreadException |
5001 | 73 |
quitMessage ["BYE"] = "bye" |
74 |
quitMessage ("BYE":msg:_) = msg |
|
75 |
quitMessage _ = error "quitMessage" |
|
4932 | 76 |
isQuit ("BYE":_) = True |
2867
9be6693c78cb
- Unbreak support for client versions prior to 0.9.13-dev
unc0rr
parents:
2352
diff
changeset
|
77 |
isQuit _ = False |