1804
|
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"
|