author | koda |
Wed, 23 Jun 2010 01:00:52 +0200 | |
changeset 3535 | 9e78c1f3d8d8 |
parent 3501 | a3159a410e5c |
child 3566 | 772a46ef8288 |
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) |
af8390d807d6
Use sockets instead of handles, use bytestrings instead of strings
unc0rr
parents:
3458
diff
changeset
|
35 |
|
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 |
3500
af8390d807d6
Use sockets instead of handles, use bytestrings instead of strings
unc0rr
parents:
3458
diff
changeset
|
56 |
clientOff msg = writeChan chan $ ClientMessage (ci, ["QUIT", msg]) |
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 |
|
af8390d807d6
Use sockets instead of handles, use bytestrings instead of strings
unc0rr
parents:
3458
diff
changeset
|
60 |
clientSendLoop :: Socket -> Chan CoreMessage -> Chan [B.ByteString] -> ClientIndex -> IO() |
af8390d807d6
Use sockets instead of handles, use bytestrings instead of strings
unc0rr
parents:
3458
diff
changeset
|
61 |
clientSendLoop s coreChan 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 |
9be6693c78cb
- Unbreak support for client versions prior to 0.9.13-dev
unc0rr
parents:
2352
diff
changeset
|
63 |
doClose <- Exception.handle |
9be6693c78cb
- Unbreak support for client versions prior to 0.9.13-dev
unc0rr
parents:
2352
diff
changeset
|
64 |
(\(e :: Exception.IOException) -> if isQuit answer then return True else sendQuit e >> return False) $ 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') |
2954 | 66 |
return $ isQuit answer |
1804 | 67 |
|
2867
9be6693c78cb
- Unbreak support for client versions prior to 0.9.13-dev
unc0rr
parents:
2352
diff
changeset
|
68 |
if doClose then |
3500
af8390d807d6
Use sockets instead of handles, use bytestrings instead of strings
unc0rr
parents:
3458
diff
changeset
|
69 |
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
|
70 |
else |
3500
af8390d807d6
Use sockets instead of handles, use bytestrings instead of strings
unc0rr
parents:
3458
diff
changeset
|
71 |
clientSendLoop s coreChan chan ci |
1804 | 72 |
|
2867
9be6693c78cb
- Unbreak support for client versions prior to 0.9.13-dev
unc0rr
parents:
2352
diff
changeset
|
73 |
where |
3500
af8390d807d6
Use sockets instead of handles, use bytestrings instead of strings
unc0rr
parents:
3458
diff
changeset
|
74 |
sendQuit e = writeChan coreChan $ ClientMessage (ci, ["QUIT", B.pack $ 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 |