author | Palewolf |
Thu, 04 Nov 2010 00:05:58 +0100 | |
changeset 4108 | 186d4c163530 |
parent 3947 | 709fdb89f76c |
child 4242 | 5e3c5fe2cb14 |
permissions | -rw-r--r-- |
3500
af8390d807d6
Use sockets instead of handles, use bytestrings instead of strings
unc0rr
parents:
3458
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.13-dev
unc0rr
parents:
2352
diff
changeset
|
6 |
import Control.Concurrent |
1804 | 7 |
import Control.Monad |
8 |
import System.IO |
|
3500
af8390d807d6
Use sockets instead of handles, use bytestrings instead of strings
unc0rr
parents:
3458
diff
changeset
|
9 |
import Network |
af8390d807d6
Use sockets instead of handles, use bytestrings instead of strings
unc0rr
parents:
3458
diff
changeset
|
10 |
import Network.Socket.ByteString |
af8390d807d6
Use sockets instead of handles, use bytestrings instead of strings
unc0rr
parents:
3458
diff
changeset
|
11 |
import qualified Data.ByteString.Char8 as B |
1804 | 12 |
---------------- |
13 |
import CoreTypes |
|
3435 | 14 |
import RoomsAndClients |
3500
af8390d807d6
Use sockets instead of handles, use bytestrings instead of strings
unc0rr
parents:
3458
diff
changeset
|
15 |
import Utils |
3458 | 16 |
|
1804 | 17 |
|
3500
af8390d807d6
Use sockets instead of handles, use bytestrings instead of strings
unc0rr
parents:
3458
diff
changeset
|
18 |
pDelim :: B.ByteString |
af8390d807d6
Use sockets instead of handles, use bytestrings instead of strings
unc0rr
parents:
3458
diff
changeset
|
19 |
pDelim = B.pack "\n\n" |
af8390d807d6
Use sockets instead of handles, use bytestrings instead of strings
unc0rr
parents:
3458
diff
changeset
|
20 |
|
af8390d807d6
Use sockets instead of handles, use bytestrings instead of strings
unc0rr
parents:
3458
diff
changeset
|
21 |
bs2Packets :: B.ByteString -> ([[B.ByteString]], B.ByteString) |
af8390d807d6
Use sockets instead of handles, use bytestrings instead of strings
unc0rr
parents:
3458
diff
changeset
|
22 |
bs2Packets buf = unfoldrE extractPackets buf |
af8390d807d6
Use sockets instead of handles, use bytestrings instead of strings
unc0rr
parents:
3458
diff
changeset
|
23 |
where |
af8390d807d6
Use sockets instead of handles, use bytestrings instead of strings
unc0rr
parents:
3458
diff
changeset
|
24 |
extractPackets :: B.ByteString -> Either B.ByteString ([B.ByteString], B.ByteString) |
af8390d807d6
Use sockets instead of handles, use bytestrings instead of strings
unc0rr
parents:
3458
diff
changeset
|
25 |
extractPackets buf = |
af8390d807d6
Use sockets instead of handles, use bytestrings instead of strings
unc0rr
parents:
3458
diff
changeset
|
26 |
let buf' = until (not . B.isPrefixOf pDelim) (B.drop 2) buf in |
af8390d807d6
Use sockets instead of handles, use bytestrings instead of strings
unc0rr
parents:
3458
diff
changeset
|
27 |
let (bsPacket, bufTail) = B.breakSubstring pDelim buf' in |
af8390d807d6
Use sockets instead of handles, use bytestrings instead of strings
unc0rr
parents:
3458
diff
changeset
|
28 |
if B.null bufTail then |
af8390d807d6
Use sockets instead of handles, use bytestrings instead of strings
unc0rr
parents:
3458
diff
changeset
|
29 |
Left bsPacket |
af8390d807d6
Use sockets instead of handles, use bytestrings instead of strings
unc0rr
parents:
3458
diff
changeset
|
30 |
else |
af8390d807d6
Use sockets instead of handles, use bytestrings instead of strings
unc0rr
parents:
3458
diff
changeset
|
31 |
if B.null bsPacket then |
af8390d807d6
Use sockets instead of handles, use bytestrings instead of strings
unc0rr
parents:
3458
diff
changeset
|
32 |
Left bufTail |
af8390d807d6
Use sockets instead of handles, use bytestrings instead of strings
unc0rr
parents:
3458
diff
changeset
|
33 |
else |
af8390d807d6
Use sockets instead of handles, use bytestrings instead of strings
unc0rr
parents:
3458
diff
changeset
|
34 |
Right (B.splitWith (== '\n') bsPacket, bufTail) |
3566 | 35 |
|
3500
af8390d807d6
Use sockets instead of handles, use bytestrings instead of strings
unc0rr
parents:
3458
diff
changeset
|
36 |
|
af8390d807d6
Use sockets instead of handles, use bytestrings instead of strings
unc0rr
parents:
3458
diff
changeset
|
37 |
listenLoop :: Socket -> Chan CoreMessage -> ClientIndex -> IO () |
af8390d807d6
Use sockets instead of handles, use bytestrings instead of strings
unc0rr
parents:
3458
diff
changeset
|
38 |
listenLoop sock chan ci = recieveWithBufferLoop B.empty |
af8390d807d6
Use sockets instead of handles, use bytestrings instead of strings
unc0rr
parents:
3458
diff
changeset
|
39 |
where |
af8390d807d6
Use sockets instead of handles, use bytestrings instead of strings
unc0rr
parents:
3458
diff
changeset
|
40 |
recieveWithBufferLoop recvBuf = do |
af8390d807d6
Use sockets instead of handles, use bytestrings instead of strings
unc0rr
parents:
3458
diff
changeset
|
41 |
recvBS <- recv sock 4096 |
3501 | 42 |
-- putStrLn $ show sock ++ " got smth: " ++ (show $ B.length recvBS) |
3500
af8390d807d6
Use sockets instead of handles, use bytestrings instead of strings
unc0rr
parents:
3458
diff
changeset
|
43 |
unless (B.null recvBS) $ do |
af8390d807d6
Use sockets instead of handles, use bytestrings instead of strings
unc0rr
parents:
3458
diff
changeset
|
44 |
let (packets, newrecvBuf) = bs2Packets $ B.append recvBuf recvBS |
af8390d807d6
Use sockets instead of handles, use bytestrings instead of strings
unc0rr
parents:
3458
diff
changeset
|
45 |
forM_ packets sendPacket |
af8390d807d6
Use sockets instead of handles, use bytestrings instead of strings
unc0rr
parents:
3458
diff
changeset
|
46 |
recieveWithBufferLoop newrecvBuf |
af8390d807d6
Use sockets instead of handles, use bytestrings instead of strings
unc0rr
parents:
3458
diff
changeset
|
47 |
|
af8390d807d6
Use sockets instead of handles, use bytestrings instead of strings
unc0rr
parents:
3458
diff
changeset
|
48 |
sendPacket packet = writeChan chan $ ClientMessage (ci, packet) |
af8390d807d6
Use sockets instead of handles, use bytestrings instead of strings
unc0rr
parents:
3458
diff
changeset
|
49 |
|
af8390d807d6
Use sockets instead of handles, use bytestrings instead of strings
unc0rr
parents:
3458
diff
changeset
|
50 |
|
af8390d807d6
Use sockets instead of handles, use bytestrings instead of strings
unc0rr
parents:
3458
diff
changeset
|
51 |
clientRecvLoop :: Socket -> Chan CoreMessage -> ClientIndex -> IO () |
af8390d807d6
Use sockets instead of handles, use bytestrings instead of strings
unc0rr
parents:
3458
diff
changeset
|
52 |
clientRecvLoop s chan ci = do |
af8390d807d6
Use sockets instead of handles, use bytestrings instead of strings
unc0rr
parents:
3458
diff
changeset
|
53 |
msg <- (listenLoop s chan ci >> return "Connection closed") `catch` (return . B.pack . show) |
af8390d807d6
Use sockets instead of handles, use bytestrings instead of strings
unc0rr
parents:
3458
diff
changeset
|
54 |
clientOff msg |
3458 | 55 |
where |
3566 | 56 |
clientOff msg = mapM_ (writeChan chan) [ClientMessage (ci, ["QUIT", msg]), Remove ci] |
3500
af8390d807d6
Use sockets instead of handles, use bytestrings instead of strings
unc0rr
parents:
3458
diff
changeset
|
57 |
|
1804 | 58 |
|
3500
af8390d807d6
Use sockets instead of handles, use bytestrings instead of strings
unc0rr
parents:
3458
diff
changeset
|
59 |
|
3947
709fdb89f76c
Some screwing around in try to fix space leak. No luck yet.
unc0rr
parents:
3673
diff
changeset
|
60 |
clientSendLoop :: Socket -> Chan [B.ByteString] -> ClientIndex -> IO () |
709fdb89f76c
Some screwing around in try to fix space leak. No luck yet.
unc0rr
parents:
3673
diff
changeset
|
61 |
clientSendLoop s chan ci = do |
2867
9be6693c78cb
- Unbreak support for client versions prior to 0.9.13-dev
unc0rr
parents:
2352
diff
changeset
|
62 |
answer <- readChan chan |
3673
45778b16b224
Some comments on the reason of the bug, leave bug not fixed yet
unc0rr
parents:
3671
diff
changeset
|
63 |
Exception.handle |
45778b16b224
Some comments on the reason of the bug, leave bug not fixed yet
unc0rr
parents:
3671
diff
changeset
|
64 |
(\(e :: Exception.IOException) -> when (not $ isQuit answer) $ sendQuit e) $ do |
3500
af8390d807d6
Use sockets instead of handles, use bytestrings instead of strings
unc0rr
parents:
3458
diff
changeset
|
65 |
sendAll s $ (B.unlines answer) `B.append` (B.singleton '\n') |
1804 | 66 |
|
3673
45778b16b224
Some comments on the reason of the bug, leave bug not fixed yet
unc0rr
parents:
3671
diff
changeset
|
67 |
if (isQuit answer) then |
3500
af8390d807d6
Use sockets instead of handles, use bytestrings instead of strings
unc0rr
parents:
3458
diff
changeset
|
68 |
Exception.handle (\(_ :: Exception.IOException) -> putStrLn "error on sClose") $ sClose s |
2867
9be6693c78cb
- Unbreak support for client versions prior to 0.9.13-dev
unc0rr
parents:
2352
diff
changeset
|
69 |
else |
3947
709fdb89f76c
Some screwing around in try to fix space leak. No luck yet.
unc0rr
parents:
3673
diff
changeset
|
70 |
clientSendLoop s chan ci |
1804 | 71 |
|
2867
9be6693c78cb
- Unbreak support for client versions prior to 0.9.13-dev
unc0rr
parents:
2352
diff
changeset
|
72 |
where |
3673
45778b16b224
Some comments on the reason of the bug, leave bug not fixed yet
unc0rr
parents:
3671
diff
changeset
|
73 |
--sendQuit e = writeChan coreChan $ ClientMessage (ci, ["QUIT", B.pack $ show e]) |
45778b16b224
Some comments on the reason of the bug, leave bug not fixed yet
unc0rr
parents:
3671
diff
changeset
|
74 |
sendQuit e = putStrLn $ show e |
2867
9be6693c78cb
- Unbreak support for client versions prior to 0.9.13-dev
unc0rr
parents:
2352
diff
changeset
|
75 |
isQuit ("BYE":xs) = True |
9be6693c78cb
- Unbreak support for client versions prior to 0.9.13-dev
unc0rr
parents:
2352
diff
changeset
|
76 |
isQuit _ = False |