author | nemo |
Sun, 05 Aug 2012 20:18:16 -0400 | |
changeset 7505 | 94e1fa117081 |
parent 7388 | 92535bc7e928 |
child 8371 | 0551b5c3de9a |
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 = |
|
7321
57bd4f201401
- Try sending remove message in 'finally' as a last resort
unc0rr
parents:
7252
diff
changeset
|
46 |
(myThreadId >>= |
5077 | 47 |
\t -> (restore $ forkIO (clientSendLoop s t clChan ci) >> |
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) |
7321
57bd4f201401
- Try sending remove message in 'finally' as a last resort
unc0rr
parents:
7252
diff
changeset
|
52 |
>>= 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
|
53 |
where |
6e747aef012f
Another approach for fixing listener thread issues, should finally get rid of all problems. Not tested.
unc0rr
parents:
4579
diff
changeset
|
54 |
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
|
55 |
remove = do |
57bd4f201401
- Try sending remove message in 'finally' as a last resort
unc0rr
parents:
7252
diff
changeset
|
56 |
clientOff "Client is in some weird state" |
57bd4f201401
- Try sending remove message in 'finally' as a last resort
unc0rr
parents:
7252
diff
changeset
|
57 |
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
|
58 |
|
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 |
|
5059
68a5415ca8ea
More creation of sender thread to the reciever thread
unc0rr
parents:
5037
diff
changeset
|
61 |
clientSendLoop :: Socket -> ThreadId -> Chan [B.ByteString] -> ClientIndex -> IO () |
68a5415ca8ea
More creation of sender thread to the reciever thread
unc0rr
parents:
5037
diff
changeset
|
62 |
clientSendLoop s tId chan ci = do |
4568 | 63 |
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
|
64 |
|
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 |
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
|
66 |
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
|
67 |
|
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
|
68 |
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
|
69 |
(\(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
|
70 |
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
|
71 |
|
4932 | 72 |
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
|
73 |
sClose s |
2867
9be6693c78cb
- Unbreak support for client versions prior to 0.9.13-dev
unc0rr
parents:
2352
diff
changeset
|
74 |
else |
5059
68a5415ca8ea
More creation of sender thread to the reciever thread
unc0rr
parents:
5037
diff
changeset
|
75 |
clientSendLoop s tId chan ci |
1804 | 76 |
|
2867
9be6693c78cb
- Unbreak support for client versions prior to 0.9.13-dev
unc0rr
parents:
2352
diff
changeset
|
77 |
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
|
78 |
killReciever = Exception.throwTo tId . ShutdownThreadException |
5001 | 79 |
quitMessage ["BYE"] = "bye" |
80 |
quitMessage ("BYE":msg:_) = msg |
|
81 |
quitMessage _ = error "quitMessage" |
|
4932 | 82 |
isQuit ("BYE":_) = True |
2867
9be6693c78cb
- Unbreak support for client versions prior to 0.9.13-dev
unc0rr
parents:
2352
diff
changeset
|
83 |
isQuit _ = False |