author  unc0rr 
Sun, 06 Feb 2011 21:50:29 +0300  
changeset 4932  f11d80bac7ed 
parent 4904  0eab727d4717 
child 4982  3572eaf14340 
permissions  rwrr 
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 
1804  5 
import Control.Concurrent.Chan 
2867
9be6693c78cb
 Unbreak support for client versions prior to 0.9.13dev
unc0rr
parents:
2352
diff
changeset

6 
import Control.Concurrent 
1804  7 
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

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 
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 Utils 
3458  15 

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

16 

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 
pDelim :: B.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

18 
pDelim = B.pack "\n\n" 
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

19 

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 
bs2Packets :: B.ByteString > ([[B.ByteString]], B.ByteString) 
4932  21 
bs2Packets = unfoldrE extractPackets 
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 
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

23 
extractPackets :: B.ByteString > Either B.ByteString ([B.ByteString], B.ByteString) 
4932  24 
extractPackets buf = 
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

25 
let buf' = until (not . B.isPrefixOf pDelim) (B.drop 2) buf in 
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

26 
let (bsPacket, bufTail) = B.breakSubstring pDelim buf' in 
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

27 
if B.null bufTail then 
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

28 
Left bsPacket 
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

29 
else 
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

30 
if B.null bsPacket then 
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

31 
Left bufTail 
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 
else 
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 
Right (B.splitWith (== '\n') bsPacket, bufTail) 
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 

3500
af8390d807d6
Use sockets instead of handles, use bytestrings instead of strings
unc0rr
parents:
3458
diff
changeset

35 

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 
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

37 
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

38 
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

39 
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

40 
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

41 
 putStrLn $ show sock ++ " got smth: " ++ (show $ B.length 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

42 
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

43 
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

44 
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

45 
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

46 

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

47 
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

48 

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

49 

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

50 
clientRecvLoop :: 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

51 
clientRecvLoop s chan ci = 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

52 
msg < (listenLoop s chan ci >> return "Connection closed") `catch` (return . B.pack . show) 
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

53 
clientOff msg 
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]) 
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

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 

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 

4585
6e747aef012f
Another approach for fixing listener thread issues, should finally get rid of all problems. Not tested.
unc0rr
parents:
4579
diff
changeset

59 
clientSendLoop :: Socket > ThreadId > Chan CoreMessage > Chan [B.ByteString] > ClientIndex > IO () 
4932  60 
clientSendLoop s tId cChan chan ci = do 
4568  61 
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

62 
Exception.handle 
4932  63 
(\(e :: Exception.IOException) > unless (isQuit answer) $ sendQuit e) $ 
64 
sendAll s $ B.unlines answer `B.append` B.singleton '\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

65 

4932  66 
if isQuit answer then 
4579
4e61c2a42121
Explicitly kill listening thread in try to prevent messages recieving bugs
unc0rr
parents:
4295
diff
changeset

67 
do 
4585
6e747aef012f
Another approach for fixing listener thread issues, should finally get rid of all problems. Not tested.
unc0rr
parents:
4579
diff
changeset

68 
Exception.handle (\(_ :: Exception.IOException) > putStrLn "error on sClose") $ sClose s 
4579
4e61c2a42121
Explicitly kill listening thread in try to prevent messages recieving bugs
unc0rr
parents:
4295
diff
changeset

69 
killThread tId 
4932  70 
writeChan cChan $ Remove ci 
2867
9be6693c78cb
 Unbreak support for client versions prior to 0.9.13dev
unc0rr
parents:
2352
diff
changeset

71 
else 
4932  72 
clientSendLoop s tId cChan chan ci 
1804  73 

2867
9be6693c78cb
 Unbreak support for client versions prior to 0.9.13dev
unc0rr
parents:
2352
diff
changeset

74 
where 
4608
d0f758d0ff91
Make client quit on send exception (was commented due to another approach in handling connection lost)
unc0rr
parents:
4585
diff
changeset

75 
sendQuit e = do 
4932  76 
print e 
77 
writeChan cChan $ ClientMessage (ci, ["QUIT", B.pack $ show e]) 

78 
isQuit ("BYE":_) = True 

2867
9be6693c78cb
 Unbreak support for client versions prior to 0.9.13dev
unc0rr
parents:
2352
diff
changeset

79 
isQuit _ = False 