1 {-# LANGUAGE ScopedTypeVariables, OverloadedStrings #-} |
1 {-# LANGUAGE ScopedTypeVariables, OverloadedStrings, Rank2Types #-} |
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.Monad.State |
5 import Control.Monad.State |
6 import Control.Concurrent.Chan |
6 import Control.Concurrent.Chan |
28 if B.null packet then return [] else |
28 if B.null packet then return [] else |
29 do packets <- takePacks |
29 do packets <- takePacks |
30 return (B.splitWith (== '\n') packet : packets) |
30 return (B.splitWith (== '\n') packet : packets) |
31 |
31 |
32 listenLoop :: Socket -> Chan CoreMessage -> ClientIndex -> IO () |
32 listenLoop :: Socket -> Chan CoreMessage -> ClientIndex -> IO () |
33 listenLoop sock chan ci = Exception.unblock $ recieveWithBufferLoop B.empty |
33 listenLoop sock chan ci = recieveWithBufferLoop B.empty |
34 where |
34 where |
35 recieveWithBufferLoop recvBuf = do |
35 recieveWithBufferLoop recvBuf = do |
36 recvBS <- recv sock 4096 |
36 recvBS <- recv sock 4096 |
37 unless (B.null recvBS) $ do |
37 unless (B.null recvBS) $ do |
38 let (packets, newrecvBuf) = bs2Packets $ B.append recvBuf recvBS |
38 let (packets, newrecvBuf) = bs2Packets $ B.append recvBuf recvBS |
39 forM_ packets sendPacket |
39 forM_ packets sendPacket |
40 recieveWithBufferLoop newrecvBuf |
40 recieveWithBufferLoop newrecvBuf |
41 |
41 |
42 sendPacket packet = writeChan chan $ ClientMessage (ci, packet) |
42 sendPacket packet = writeChan chan $ ClientMessage (ci, packet) |
43 |
43 |
44 clientRecvLoop :: Socket -> Chan CoreMessage -> Chan [B.ByteString] -> ClientIndex -> IO () |
44 clientRecvLoop :: Socket -> Chan CoreMessage -> Chan [B.ByteString] -> ClientIndex -> (forall a. IO a -> IO a) -> IO () |
45 clientRecvLoop s chan clChan ci = |
45 clientRecvLoop s chan clChan ci restore = |
46 myThreadId >>= |
46 myThreadId >>= |
47 \t -> forkIO (clientSendLoop s t clChan ci) >> |
47 \t -> (restore $ forkIO (clientSendLoop s t clChan ci) >> |
48 (listenLoop s chan ci >> return "Connection closed") |
48 listenLoop s chan ci >> return "Connection closed") |
49 `Exception.catch` (\(e :: Exception.IOException) -> return . B.pack . show $ e) |
49 `Exception.catch` (\(e :: Exception.IOException) -> return . B.pack . show $ e) |
50 `Exception.catch` (\(e :: ShutdownThreadException) -> return . B.pack . show $ e) |
50 `Exception.catch` (\(e :: ShutdownThreadException) -> return . B.pack . show $ e) |
51 >>= clientOff >> remove |
51 >>= clientOff >> remove |
52 where |
52 where |
53 clientOff msg = writeChan chan $ ClientMessage (ci, ["QUIT", msg]) |
53 clientOff msg = writeChan chan $ ClientMessage (ci, ["QUIT", msg]) |