3 |
3 |
4 import qualified Control.Exception as Exception |
4 import qualified Control.Exception as Exception |
5 import Control.Monad.State |
5 import Control.Monad.State |
6 import Control.Concurrent.Chan |
6 import Control.Concurrent.Chan |
7 import Control.Concurrent |
7 import Control.Concurrent |
8 import Control.Monad |
|
9 import Network |
8 import Network |
10 import Network.Socket.ByteString |
9 import Network.Socket.ByteString |
11 import qualified Data.ByteString.Char8 as B |
10 import qualified Data.ByteString.Char8 as B |
12 ---------------- |
11 ---------------- |
13 import CoreTypes |
12 import CoreTypes |
14 import RoomsAndClients |
13 import RoomsAndClients |
15 import Utils |
|
16 |
14 |
17 |
15 |
18 pDelim :: B.ByteString |
16 pDelim :: B.ByteString |
19 pDelim = "\n\n" |
17 pDelim = "\n\n" |
20 |
18 |
|
19 bs2Packets :: B.ByteString -> ([[B.ByteString]], B.ByteString) |
21 bs2Packets = runState takePacks |
20 bs2Packets = runState takePacks |
22 |
21 |
23 takePacks :: State B.ByteString [[B.ByteString]] |
22 takePacks :: State B.ByteString [[B.ByteString]] |
24 takePacks |
23 takePacks |
25 = do modify (until (not . B.isPrefixOf pDelim) (B.drop 2)) |
24 = do modify (until (not . B.isPrefixOf pDelim) (B.drop 2)) |
29 if B.null packet then return [] else |
28 if B.null packet then return [] else |
30 do packets <- takePacks |
29 do packets <- takePacks |
31 return (B.splitWith (== '\n') packet : packets) |
30 return (B.splitWith (== '\n') packet : packets) |
32 |
31 |
33 listenLoop :: Socket -> Chan CoreMessage -> ClientIndex -> IO () |
32 listenLoop :: Socket -> Chan CoreMessage -> ClientIndex -> IO () |
34 listenLoop sock chan ci = recieveWithBufferLoop B.empty |
33 listenLoop sock chan ci = Exception.unblock $ recieveWithBufferLoop B.empty |
35 where |
34 where |
36 recieveWithBufferLoop recvBuf = do |
35 recieveWithBufferLoop recvBuf = do |
37 recvBS <- recv sock 4096 |
36 recvBS <- recv sock 4096 |
38 unless (B.null recvBS) $ do |
37 unless (B.null recvBS) $ do |
39 let (packets, newrecvBuf) = bs2Packets $ B.append recvBuf recvBS |
38 let (packets, newrecvBuf) = bs2Packets $ B.append recvBuf recvBS |
40 forM_ packets sendPacket |
39 forM_ packets sendPacket |
41 recieveWithBufferLoop newrecvBuf |
40 recieveWithBufferLoop newrecvBuf |
42 |
41 |
43 sendPacket packet = writeChan chan $ ClientMessage (ci, packet) |
42 sendPacket packet = writeChan chan $ ClientMessage (ci, packet) |
44 |
43 |
45 clientRecvLoop :: Socket -> Chan CoreMessage -> ClientIndex -> IO () |
44 clientRecvLoop :: Socket -> Chan CoreMessage -> Chan [B.ByteString] -> ClientIndex -> IO () |
46 clientRecvLoop s chan ci = |
45 clientRecvLoop s chan clChan ci = |
47 (listenLoop s chan ci >> return "Connection closed") |
46 myThreadId >>= |
|
47 \t -> forkIO (clientSendLoop s t clChan ci) >> |
|
48 (listenLoop s chan ci >> return "Connection closed") |
|
49 `Exception.catch` (\(e :: Exception.IOException) -> return . B.pack . show $ e) |
48 `Exception.catch` (\(e :: ShutdownThreadException) -> return . B.pack . show $ e) |
50 `Exception.catch` (\(e :: ShutdownThreadException) -> return . B.pack . show $ e) |
49 `Exception.catch` (\(e :: Exception.IOException) -> return . B.pack . show $ e) |
|
50 >>= clientOff >> remove |
51 >>= clientOff >> remove |
51 where |
52 where |
52 clientOff msg = writeChan chan $ ClientMessage (ci, ["QUIT", msg]) |
53 clientOff msg = writeChan chan $ ClientMessage (ci, ["QUIT", msg]) |
53 remove = writeChan chan $ Remove ci |
54 remove = writeChan chan $ Remove ci |
54 |
55 |
55 |
56 |
56 |
57 |
57 clientSendLoop :: Socket -> ThreadId -> Chan CoreMessage -> Chan [B.ByteString] -> ClientIndex -> IO () |
58 clientSendLoop :: Socket -> ThreadId -> Chan [B.ByteString] -> ClientIndex -> IO () |
58 clientSendLoop s tId cChan chan ci = do |
59 clientSendLoop s tId chan ci = do |
59 answer <- readChan chan |
60 answer <- readChan chan |
60 Exception.handle |
61 Exception.handle |
61 (\(e :: Exception.IOException) -> unless (isQuit answer) . killReciever $ show e) $ |
62 (\(e :: Exception.IOException) -> unless (isQuit answer) . killReciever $ show e) $ |
62 sendAll s $ B.unlines answer `B.snoc` '\n' |
63 sendAll s $ B.unlines answer `B.snoc` '\n' |
63 |
64 |
64 if isQuit answer then |
65 if isQuit answer then |
65 do |
66 do |
66 Exception.handle (\(_ :: Exception.IOException) -> putStrLn "error on sClose") $ sClose s |
67 Exception.handle (\(_ :: Exception.IOException) -> putStrLn "error on sClose") $ sClose s |
67 killReciever . B.unpack $ quitMessage answer |
68 killReciever . B.unpack $ quitMessage answer |
68 else |
69 else |
69 clientSendLoop s tId cChan chan ci |
70 clientSendLoop s tId chan ci |
70 |
71 |
71 where |
72 where |
72 killReciever = Exception.throwTo tId . ShutdownThreadException |
73 killReciever = Exception.throwTo tId . ShutdownThreadException |
73 quitMessage ["BYE"] = "bye" |
74 quitMessage ["BYE"] = "bye" |
74 quitMessage ("BYE":msg:_) = msg |
75 quitMessage ("BYE":msg:_) = msg |