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 |
13 import RoomsAndClients |
14 import RoomsAndClients |
14 |
15 import Utils |
15 listenLoop :: Handle -> Int -> [String] -> Chan CoreMessage -> ClientIndex -> IO () |
|
16 listenLoop handle linesNumber buf chan clientID = do |
|
17 putStrLn $ show handle ++ show buf ++ show clientID |
|
18 str <- liftM BUTF8.toString $ B.hGetLine handle |
|
19 if (linesNumber > 50) || (length str > 450) then |
|
20 protocolViolationMsg >> freeClient |
|
21 else |
|
22 if str == "" then do |
|
23 writeChan chan $ ClientMessage (clientID, reverse buf) |
|
24 yield |
|
25 listenLoop handle 0 [] chan clientID |
|
26 else |
|
27 listenLoop handle (linesNumber + 1) (str : buf) chan clientID |
|
28 where |
|
29 protocolViolationMsg = writeChan chan $ ClientMessage (clientID, ["QUIT", "Protocol violation"]) |
|
30 freeClient = writeChan chan $ FreeClient clientID |
|
31 |
16 |
32 |
17 |
33 clientRecvLoop :: Handle -> Chan CoreMessage -> ClientIndex -> IO () |
18 pDelim :: B.ByteString |
34 clientRecvLoop handle chan clientID = |
19 pDelim = B.pack "\n\n" |
35 listenLoop handle 0 [] chan clientID |
20 |
36 `catch` (\e -> clientOff (show e) >> freeClient >> return ()) |
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 |
37 where |
55 where |
38 clientOff msg = writeChan chan $ ClientMessage (clientID, ["QUIT", msg]) -- if the client disconnects, we perform as if it sent QUIT message |
56 clientOff msg = writeChan chan $ ClientMessage (ci, ["QUIT", msg]) |
39 freeClient = writeChan chan $ FreeClient clientID |
|
40 |
57 |
41 clientSendLoop :: Handle -> Chan CoreMessage -> Chan [String] -> ClientIndex -> IO() |
58 |
42 clientSendLoop handle coreChan chan clientID = do |
59 |
|
60 clientSendLoop :: Socket -> Chan CoreMessage -> Chan [B.ByteString] -> ClientIndex -> IO() |
|
61 clientSendLoop s coreChan chan ci = do |
43 answer <- readChan chan |
62 answer <- readChan chan |
44 doClose <- Exception.handle |
63 doClose <- Exception.handle |
45 (\(e :: Exception.IOException) -> if isQuit answer then return True else sendQuit e >> return False) $ do |
64 (\(e :: Exception.IOException) -> if isQuit answer then return True else sendQuit e >> return False) $ do |
46 B.hPutStrLn handle $ BUTF8.fromString $ unlines answer |
65 sendAll s $ (B.unlines answer) `B.append` (B.singleton '\n') |
47 hFlush handle |
|
48 return $ isQuit answer |
66 return $ isQuit answer |
49 |
67 |
50 if doClose then |
68 if doClose then |
51 Exception.handle (\(_ :: Exception.IOException) -> putStrLn "error on hClose") $ hClose handle |
69 Exception.handle (\(_ :: Exception.IOException) -> putStrLn "error on sClose") $ sClose s |
52 else |
70 else |
53 clientSendLoop handle coreChan chan clientID |
71 clientSendLoop s coreChan chan ci |
54 |
72 |
55 where |
73 where |
56 sendQuit e = writeChan coreChan $ ClientMessage (clientID, ["QUIT", show e]) |
74 sendQuit e = writeChan coreChan $ ClientMessage (ci, ["QUIT", B.pack $ show e]) |
57 isQuit ("BYE":xs) = True |
75 isQuit ("BYE":xs) = True |
58 isQuit _ = False |
76 isQuit _ = False |