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.Concurrent |
7 import Control.Monad |
7 import Control.Monad |
8 import System.IO |
|
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 |
17 |
16 |
18 pDelim :: B.ByteString |
17 pDelim :: B.ByteString |
19 pDelim = B.pack "\n\n" |
18 pDelim = B.pack "\n\n" |
20 |
19 |
21 bs2Packets :: B.ByteString -> ([[B.ByteString]], B.ByteString) |
20 bs2Packets :: B.ByteString -> ([[B.ByteString]], B.ByteString) |
22 bs2Packets buf = unfoldrE extractPackets buf |
21 bs2Packets = unfoldrE extractPackets |
23 where |
22 where |
24 extractPackets :: B.ByteString -> Either B.ByteString ([B.ByteString], B.ByteString) |
23 extractPackets :: B.ByteString -> Either B.ByteString ([B.ByteString], B.ByteString) |
25 extractPackets buf = |
24 extractPackets buf = |
26 let buf' = until (not . B.isPrefixOf pDelim) (B.drop 2) buf in |
25 let buf' = until (not . B.isPrefixOf pDelim) (B.drop 2) buf in |
27 let (bsPacket, bufTail) = B.breakSubstring pDelim buf' in |
26 let (bsPacket, bufTail) = B.breakSubstring pDelim buf' in |
28 if B.null bufTail then |
27 if B.null bufTail then |
29 Left bsPacket |
28 Left bsPacket |
30 else |
29 else |
56 clientOff msg = writeChan chan $ ClientMessage (ci, ["QUIT", msg]) |
55 clientOff msg = writeChan chan $ ClientMessage (ci, ["QUIT", msg]) |
57 |
56 |
58 |
57 |
59 |
58 |
60 clientSendLoop :: Socket -> ThreadId -> Chan CoreMessage -> Chan [B.ByteString] -> ClientIndex -> IO () |
59 clientSendLoop :: Socket -> ThreadId -> Chan CoreMessage -> Chan [B.ByteString] -> ClientIndex -> IO () |
61 clientSendLoop s tId coreChan chan ci = do |
60 clientSendLoop s tId cChan chan ci = do |
62 answer <- readChan chan |
61 answer <- readChan chan |
63 Exception.handle |
62 Exception.handle |
64 (\(e :: Exception.IOException) -> when (not $ isQuit answer) $ sendQuit e) $ do |
63 (\(e :: Exception.IOException) -> unless (isQuit answer) $ sendQuit e) $ |
65 sendAll s $ (B.unlines answer) `B.append` (B.singleton '\n') |
64 sendAll s $ B.unlines answer `B.append` B.singleton '\n' |
66 |
65 |
67 if (isQuit answer) then |
66 if isQuit answer then |
68 do |
67 do |
69 Exception.handle (\(_ :: Exception.IOException) -> putStrLn "error on sClose") $ sClose s |
68 Exception.handle (\(_ :: Exception.IOException) -> putStrLn "error on sClose") $ sClose s |
70 killThread tId |
69 killThread tId |
71 writeChan coreChan $ Remove ci |
70 writeChan cChan $ Remove ci |
72 else |
71 else |
73 clientSendLoop s tId coreChan chan ci |
72 clientSendLoop s tId cChan chan ci |
74 |
73 |
75 where |
74 where |
76 sendQuit e = do |
75 sendQuit e = do |
77 putStrLn $ show e |
76 print e |
78 writeChan coreChan $ ClientMessage (ci, ["QUIT", B.pack $ show e]) |
77 writeChan cChan $ ClientMessage (ci, ["QUIT", B.pack $ show e]) |
79 isQuit ("BYE":xs) = True |
78 isQuit ("BYE":_) = True |
80 isQuit _ = False |
79 isQuit _ = False |