1 {-# LANGUAGE ScopedTypeVariables, OverloadedStrings #-} |
1 {-# LANGUAGE ScopedTypeVariables #-} |
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 Network |
9 import qualified Data.ByteString.UTF8 as BUTF8 |
10 import Network.Socket.ByteString |
10 import qualified Data.ByteString as B |
11 import qualified Data.ByteString.Char8 as B |
|
12 ---------------- |
11 ---------------- |
13 import CoreTypes |
12 import CoreTypes |
14 import RoomsAndClients |
|
15 import Utils |
|
16 |
13 |
|
14 listenLoop :: Handle -> Int -> [String] -> Chan CoreMessage -> Int -> IO () |
|
15 listenLoop handle linesNumber buf chan clientID = do |
|
16 str <- liftM BUTF8.toString $ B.hGetLine handle |
|
17 if (linesNumber > 50) || (length str > 450) then |
|
18 writeChan chan $ ClientMessage (clientID, ["QUIT", "Protocol violation"]) |
|
19 else |
|
20 if str == "" then do |
|
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 |
17 |
26 |
18 pDelim :: B.ByteString |
27 clientRecvLoop :: Handle -> Chan CoreMessage -> Int -> IO () |
19 pDelim = B.pack "\n\n" |
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 |
20 |
32 |
21 bs2Packets :: B.ByteString -> ([[B.ByteString]], B.ByteString) |
33 clientSendLoop :: Handle -> Chan CoreMessage -> Chan [String] -> Int -> IO() |
22 bs2Packets buf = unfoldrE extractPackets buf |
34 clientSendLoop handle coreChan chan clientID = do |
23 where |
35 answer <- readChan chan |
24 extractPackets :: B.ByteString -> Either B.ByteString ([B.ByteString], B.ByteString) |
36 doClose <- Exception.handle |
25 extractPackets buf = |
37 (\(e :: Exception.IOException) -> if isQuit answer then return True else sendQuit e >> return False) $ do |
26 let buf' = until (not . B.isPrefixOf pDelim) (B.drop 2) buf in |
38 B.hPutStrLn handle $ BUTF8.fromString $ unlines answer |
27 let (bsPacket, bufTail) = B.breakSubstring pDelim buf' in |
39 hFlush handle |
28 if B.null bufTail then |
40 return $ isQuit answer |
29 Left bsPacket |
|
30 else |
|
31 if B.null bsPacket then |
|
32 Left bufTail |
|
33 else |
|
34 Right (B.splitWith (== '\n') bsPacket, bufTail) |
|
35 |
41 |
36 |
42 if doClose then |
37 listenLoop :: Socket -> Chan CoreMessage -> ClientIndex -> IO () |
43 Exception.handle (\(_ :: Exception.IOException) -> putStrLn "error on hClose") $ hClose handle |
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 = mapM_ (writeChan chan) [ClientMessage (ci, ["QUIT", msg]), Remove ci] |
|
57 |
|
58 |
|
59 |
|
60 clientSendLoop :: Socket -> Chan [B.ByteString] -> ClientIndex -> IO () |
|
61 clientSendLoop s 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 Exception.handle (\(_ :: Exception.IOException) -> putStrLn "error on sClose") $ sClose s |
|
69 else |
44 else |
70 clientSendLoop s chan ci |
45 clientSendLoop handle coreChan chan clientID |
71 |
46 |
72 where |
47 where |
73 --sendQuit e = writeChan coreChan $ ClientMessage (ci, ["QUIT", B.pack $ show e]) |
48 sendQuit e = writeChan coreChan $ ClientMessage (clientID, ["QUIT", show e]) |
74 sendQuit e = putStrLn $ show e |
|
75 isQuit ("BYE":xs) = True |
49 isQuit ("BYE":xs) = True |
76 isQuit _ = False |
50 isQuit _ = False |