|
1 {-# LANGUAGE PatternSignatures #-} |
|
2 module ClientIO where |
|
3 |
|
4 import qualified Control.Exception |
|
5 import Control.Concurrent.Chan |
|
6 import Control.Monad |
|
7 import System.IO |
|
8 ---------------- |
|
9 import CoreTypes |
|
10 |
|
11 listenLoop :: Handle -> [String] -> Chan CoreMessage -> Int -> IO () |
|
12 listenLoop handle buf chan clientID = do |
|
13 str <- hGetLine handle |
|
14 if str == "" then do |
|
15 writeChan chan $ ClientMessage (clientID, buf) |
|
16 listenLoop handle [] chan clientID |
|
17 else |
|
18 listenLoop handle (buf ++ [str]) chan clientID |
|
19 |
|
20 clientRecvLoop :: Handle -> Chan CoreMessage -> Int -> IO () |
|
21 clientRecvLoop handle chan clientID = |
|
22 listenLoop handle [] chan clientID |
|
23 `catch` (\e -> (clientOff $ show e) >> return ()) |
|
24 where clientOff msg = writeChan chan $ ClientMessage (clientID, ["QUIT", msg]) -- if the client disconnects, we perform as if it sent QUIT message |
|
25 |
|
26 clientSendLoop :: Handle -> Chan CoreMessage -> Chan [String] -> Int -> IO() |
|
27 clientSendLoop handle coreChan chan clientID = do |
|
28 answer <- readChan chan |
|
29 doClose <- Control.Exception.handle |
|
30 (\(e :: Control.Exception.Exception) -> if isQuit answer then return True else sendQuit e >> return False) $ do |
|
31 forM_ answer (\str -> hPutStrLn handle str) |
|
32 hPutStrLn handle "" |
|
33 hFlush handle |
|
34 return $ isQuit answer |
|
35 |
|
36 if doClose then |
|
37 Control.Exception.handle (\(_ :: Control.Exception.Exception) -> putStrLn "error on hClose") $ hClose handle |
|
38 else |
|
39 clientSendLoop handle coreChan chan clientID |
|
40 |
|
41 where |
|
42 sendQuit e = writeChan coreChan $ ClientMessage (clientID, ["QUIT", show e]) |
|
43 isQuit answer = head answer == "BYE" |