1 {-# LANGUAGE ScopedTypeVariables #-} |
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.Monad |
7 import Control.Monad |
7 import System.IO |
8 import System.IO |
8 ---------------- |
9 ---------------- |
9 import CoreTypes |
10 import CoreTypes |
10 |
11 |
11 listenLoop :: Handle -> Int -> [String] -> Chan CoreMessage -> Int -> IO () |
12 listenLoop :: Handle -> Int -> [String] -> Chan CoreMessage -> Int -> IO () |
12 listenLoop handle linesNumber buf chan clientID = do |
13 listenLoop handle linesNumber buf chan clientID = do |
13 str <- hGetLine handle |
14 str <- hGetLine handle |
14 if (linesNumber > 50) || (length str > 450) then |
15 if (linesNumber > 50) || (length str > 450) then |
15 writeChan chan $ ClientMessage (clientID, ["QUIT", "Protocol violation"]) |
16 writeChan chan $ ClientMessage (clientID, ["QUIT", "Protocol violation"]) |
16 else |
17 else |
17 if str == "" then do |
18 if str == "" then do |
18 writeChan chan $ ClientMessage (clientID, buf) |
19 writeChan chan $ ClientMessage (clientID, buf) |
19 listenLoop handle 0 [] chan clientID |
20 yield |
20 else |
21 listenLoop handle 0 [] chan clientID |
21 listenLoop handle (linesNumber + 1) (buf ++ [str]) chan clientID |
22 else |
|
23 listenLoop handle (linesNumber + 1) (buf ++ [str]) chan clientID |
22 |
24 |
23 clientRecvLoop :: Handle -> Chan CoreMessage -> Int -> IO () |
25 clientRecvLoop :: Handle -> Chan CoreMessage -> Int -> IO () |
24 clientRecvLoop handle chan clientID = |
26 clientRecvLoop handle chan clientID = |
25 listenLoop handle 0 [] chan clientID |
27 listenLoop handle 0 [] chan clientID |
26 `catch` (\e -> clientOff (show e) >> return ()) |
28 `catch` (\e -> clientOff (show e) >> return ()) |
27 where clientOff msg = writeChan chan $ ClientMessage (clientID, ["QUIT", msg]) -- if the client disconnects, we perform as if it sent QUIT message |
29 where clientOff msg = writeChan chan $ ClientMessage (clientID, ["QUIT", msg]) -- if the client disconnects, we perform as if it sent QUIT message |
28 |
30 |
29 clientSendLoop :: Handle -> Chan CoreMessage -> Chan [String] -> Int -> IO() |
31 clientSendLoop :: Handle -> Chan CoreMessage -> Chan [String] -> Int -> IO() |
30 clientSendLoop handle coreChan chan clientID = do |
32 clientSendLoop handle coreChan chan clientID = do |
31 answer <- readChan chan |
33 answer <- readChan chan |
32 doClose <- Exception.handle |
34 doClose <- Exception.handle |
33 (\(e :: Exception.IOException) -> if isQuit answer then return True else sendQuit e >> return False) $ do |
35 (\(e :: Exception.IOException) -> if isQuit answer then return True else sendQuit e >> return False) $ do |
34 forM_ answer (hPutStrLn handle) |
36 forM_ answer (hPutStrLn handle) |
35 hPutStrLn handle "" |
37 hPutStrLn handle "" |
36 hFlush handle |
38 hFlush handle |
37 return $ isQuit answer |
39 return $ isQuit answer |
38 |
40 |
39 if doClose then |
41 if doClose then |
40 Exception.handle (\(_ :: Exception.IOException) -> putStrLn "error on hClose") $ hClose handle |
42 Exception.handle (\(_ :: Exception.IOException) -> putStrLn "error on hClose") $ hClose handle |
41 else |
43 else |
42 clientSendLoop handle coreChan chan clientID |
44 clientSendLoop handle coreChan chan clientID |
43 |
45 |
44 where |
46 where |
45 sendQuit e = writeChan coreChan $ ClientMessage (clientID, ["QUIT", show e]) |
47 sendQuit e = writeChan coreChan $ ClientMessage (clientID, ["QUIT", show e]) |
46 isQuit ("BYE":xs) = True |
48 isQuit ("BYE":xs) = True |
47 isQuit _ = False |
49 isQuit _ = False |