author | koda |
Sun, 20 Jan 2013 22:51:26 +0100 | |
changeset 8410 | 48a7986e46f8 |
parent 8371 | 0551b5c3de9a |
child 8454 | 46b59c529bb1 |
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 () |
8371 | 33 |
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
|
34 |
where |
8371 | 35 |
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
|
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 |
8371 | 40 |
receiveWithBufferLoop 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
|
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 = |
|
7321
57bd4f201401
- Try sending remove message in 'finally' as a last resort
unc0rr
parents:
7252
diff
changeset
|
46 |
(myThreadId >>= |
8371 | 47 |
(\t -> (restore $ forkIO (clientSendLoop s t clChan ci) >> |
5077 | 48 |
listenLoop s chan ci >> return "Connection closed") |
7321
57bd4f201401
- Try sending remove message in 'finally' as a last resort
unc0rr
parents:
7252
diff
changeset
|
49 |
`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
|
50 |
`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
|
51 |
`Exception.catch` (\(e :: Exception.SomeException) -> return . B.pack . show $ e) |
8371 | 52 |
) |
7321
57bd4f201401
- Try sending remove message in 'finally' as a last resort
unc0rr
parents:
7252
diff
changeset
|
53 |
>>= 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
|
54 |
where |
6e747aef012f
Another approach for fixing listener thread issues, should finally get rid of all problems. Not tested.
unc0rr
parents:
4579
diff
changeset
|
55 |
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
|
56 |
remove = do |
57bd4f201401
- Try sending remove message in 'finally' as a last resort
unc0rr
parents:
7252
diff
changeset
|
57 |
clientOff "Client is in some weird state" |
57bd4f201401
- Try sending remove message in 'finally' as a last resort
unc0rr
parents:
7252
diff
changeset
|
58 |
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
|
59 |
|
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 |
|
5059
68a5415ca8ea
More creation of sender thread to the reciever thread
unc0rr
parents:
5037
diff
changeset
|
62 |
clientSendLoop :: Socket -> ThreadId -> Chan [B.ByteString] -> ClientIndex -> IO () |
68a5415ca8ea
More creation of sender thread to the reciever thread
unc0rr
parents:
5037
diff
changeset
|
63 |
clientSendLoop s tId chan ci = do |
4568 | 64 |
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
|
65 |
|
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
|
66 |
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
|
67 |
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
|
68 |
|
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
|
69 |
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
|
70 |
(\(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
|
71 |
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
|
72 |
|
4932 | 73 |
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
|
74 |
sClose s |
2867
9be6693c78cb
- Unbreak support for client versions prior to 0.9.13-dev
unc0rr
parents:
2352
diff
changeset
|
75 |
else |
5059
68a5415ca8ea
More creation of sender thread to the reciever thread
unc0rr
parents:
5037
diff
changeset
|
76 |
clientSendLoop s tId chan ci |
1804 | 77 |
|
2867
9be6693c78cb
- Unbreak support for client versions prior to 0.9.13-dev
unc0rr
parents:
2352
diff
changeset
|
78 |
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
|
79 |
killReciever = Exception.throwTo tId . ShutdownThreadException |
5001 | 80 |
quitMessage ["BYE"] = "bye" |
81 |
quitMessage ("BYE":msg:_) = msg |
|
82 |
quitMessage _ = error "quitMessage" |
|
4932 | 83 |
isQuit ("BYE":_) = True |
2867
9be6693c78cb
- Unbreak support for client versions prior to 0.9.13-dev
unc0rr
parents:
2352
diff
changeset
|
84 |
isQuit _ = False |