1 {-# LANGUAGE ScopedTypeVariables #-} |
1 {-# LANGUAGE ScopedTypeVariables, OverloadedStrings #-} |
2 module ClientIO where |
2 module ClientIO where |
3 |
3 |
4 import qualified Control.Exception as Exception |
4 import qualified Control.Exception as Exception |
5 import Control.Concurrent.Chan |
5 import Control.Concurrent.Chan |
6 import Control.Concurrent |
6 import Control.Concurrent |
7 import Control.Monad |
7 import Control.Monad |
8 import System.IO |
8 import System.IO |
9 import qualified Data.ByteString.UTF8 as BUTF8 |
9 import Network |
10 import qualified Data.ByteString as B |
10 import Network.Socket.ByteString |
|
11 import qualified Data.ByteString.Char8 as B |
11 ---------------- |
12 ---------------- |
12 import CoreTypes |
13 import CoreTypes |
|
14 import RoomsAndClients |
|
15 import Utils |
13 |
16 |
14 listenLoop :: Handle -> Int -> [String] -> Chan CoreMessage -> Int -> IO () |
17 |
15 listenLoop handle linesNumber buf chan clientID = do |
18 pDelim :: B.ByteString |
16 str <- liftM BUTF8.toString $ B.hGetLine handle |
19 pDelim = B.pack "\n\n" |
17 if (linesNumber > 50) || (length str > 20000) then |
20 |
18 writeChan chan $ ClientMessage (clientID, ["QUIT", "Protocol violation"]) |
21 bs2Packets :: B.ByteString -> ([[B.ByteString]], B.ByteString) |
|
22 bs2Packets buf = unfoldrE extractPackets buf |
|
23 where |
|
24 extractPackets :: B.ByteString -> Either B.ByteString ([B.ByteString], B.ByteString) |
|
25 extractPackets buf = |
|
26 let buf' = until (not . B.isPrefixOf pDelim) (B.drop 2) buf in |
|
27 let (bsPacket, bufTail) = B.breakSubstring pDelim buf' in |
|
28 if B.null bufTail then |
|
29 Left bsPacket |
|
30 else |
|
31 if B.null bsPacket then |
|
32 Left bufTail |
|
33 else |
|
34 Right (B.splitWith (== '\n') bsPacket, bufTail) |
|
35 |
|
36 |
|
37 listenLoop :: Socket -> Chan CoreMessage -> ClientIndex -> IO () |
|
38 listenLoop sock chan ci = recieveWithBufferLoop B.empty |
|
39 where |
|
40 recieveWithBufferLoop recvBuf = do |
|
41 recvBS <- recv sock 4096 |
|
42 -- putStrLn $ show sock ++ " got smth: " ++ (show $ B.length recvBS) |
|
43 unless (B.null recvBS) $ do |
|
44 let (packets, newrecvBuf) = bs2Packets $ B.append recvBuf recvBS |
|
45 forM_ packets sendPacket |
|
46 recieveWithBufferLoop newrecvBuf |
|
47 |
|
48 sendPacket packet = writeChan chan $ ClientMessage (ci, packet) |
|
49 |
|
50 |
|
51 clientRecvLoop :: Socket -> Chan CoreMessage -> ClientIndex -> IO () |
|
52 clientRecvLoop s chan ci = do |
|
53 msg <- (listenLoop s chan ci >> return "Connection closed") `catch` (return . B.pack . show) |
|
54 clientOff msg |
|
55 where |
|
56 clientOff msg = writeChan chan $ ClientMessage (ci, ["QUIT", msg]) |
|
57 |
|
58 |
|
59 |
|
60 clientSendLoop :: Socket -> ThreadId -> Chan CoreMessage -> Chan [B.ByteString] -> ClientIndex -> IO () |
|
61 clientSendLoop s tId coreChan chan ci = do |
|
62 answer <- readChan chan |
|
63 Exception.handle |
|
64 (\(e :: Exception.IOException) -> when (not $ isQuit answer) $ sendQuit e) $ do |
|
65 sendAll s $ (B.unlines answer) `B.append` (B.singleton '\n') |
|
66 |
|
67 if (isQuit answer) then |
|
68 do |
|
69 Exception.handle (\(_ :: Exception.IOException) -> putStrLn "error on sClose") $ sClose s |
|
70 killThread tId |
|
71 writeChan coreChan $ Remove ci |
19 else |
72 else |
20 if str == "" then do |
73 clientSendLoop s tId coreChan chan ci |
21 writeChan chan $ ClientMessage (clientID, buf) |
|
22 yield |
|
23 listenLoop handle 0 [] chan clientID |
|
24 else |
|
25 listenLoop handle (linesNumber + 1) (buf ++ [str]) chan clientID |
|
26 |
|
27 clientRecvLoop :: Handle -> Chan CoreMessage -> Int -> IO () |
|
28 clientRecvLoop handle chan clientID = |
|
29 listenLoop handle 0 [] chan clientID |
|
30 `catch` (\e -> clientOff (show e) >> return ()) |
|
31 where clientOff msg = writeChan chan $ ClientMessage (clientID, ["QUIT", msg]) -- if the client disconnects, we perform as if it sent QUIT message |
|
32 |
|
33 clientSendLoop :: Handle -> Chan CoreMessage -> Chan [String] -> Int -> IO() |
|
34 clientSendLoop handle coreChan chan clientID = do |
|
35 answer <- readChan chan |
|
36 doClose <- Exception.handle |
|
37 (\(e :: Exception.IOException) -> if isQuit answer then return True else sendQuit e >> return False) $ do |
|
38 B.hPutStrLn handle $ BUTF8.fromString $ unlines answer |
|
39 hFlush handle |
|
40 return $ isQuit answer |
|
41 |
|
42 if doClose then |
|
43 Exception.handle (\(_ :: Exception.IOException) -> putStrLn "error on hClose") $ hClose handle |
|
44 else |
|
45 clientSendLoop handle coreChan chan clientID |
|
46 |
74 |
47 where |
75 where |
48 sendQuit e = writeChan coreChan $ ClientMessage (clientID, ["QUIT", show e]) |
76 sendQuit e = do |
|
77 putStrLn $ show e |
|
78 writeChan coreChan $ ClientMessage (ci, ["QUIT", B.pack $ show e]) |
49 isQuit ("BYE":xs) = True |
79 isQuit ("BYE":xs) = True |
50 isQuit _ = False |
80 isQuit _ = False |