diff -r 66eba4e41b91 -r af8390d807d6 gameServer/ClientIO.hs --- a/gameServer/ClientIO.hs Sat Jun 05 20:49:51 2010 +0000 +++ b/gameServer/ClientIO.hs Sun Jun 06 15:29:33 2010 +0000 @@ -1,4 +1,4 @@ -{-# LANGUAGE ScopedTypeVariables #-} +{-# LANGUAGE ScopedTypeVariables, OverloadedStrings #-} module ClientIO where import qualified Control.Exception as Exception @@ -6,53 +6,71 @@ import Control.Concurrent import Control.Monad import System.IO -import qualified Data.ByteString.UTF8 as BUTF8 -import qualified Data.ByteString as B +import Network +import Network.Socket.ByteString +import qualified Data.ByteString.Char8 as B ---------------- import CoreTypes import RoomsAndClients - -listenLoop :: Handle -> Int -> [String] -> Chan CoreMessage -> ClientIndex -> IO () -listenLoop handle linesNumber buf chan clientID = do - putStrLn $ show handle ++ show buf ++ show clientID - str <- liftM BUTF8.toString $ B.hGetLine handle - if (linesNumber > 50) || (length str > 450) then - protocolViolationMsg >> freeClient - else - if str == "" then do - writeChan chan $ ClientMessage (clientID, reverse buf) - yield - listenLoop handle 0 [] chan clientID - else - listenLoop handle (linesNumber + 1) (str : buf) chan clientID - where - protocolViolationMsg = writeChan chan $ ClientMessage (clientID, ["QUIT", "Protocol violation"]) - freeClient = writeChan chan $ FreeClient clientID +import Utils -clientRecvLoop :: Handle -> Chan CoreMessage -> ClientIndex -> IO () -clientRecvLoop handle chan clientID = - listenLoop handle 0 [] chan clientID - `catch` (\e -> clientOff (show e) >> freeClient >> return ()) +pDelim :: B.ByteString +pDelim = B.pack "\n\n" + +bs2Packets :: B.ByteString -> ([[B.ByteString]], B.ByteString) +bs2Packets buf = unfoldrE extractPackets buf + where + extractPackets :: B.ByteString -> Either B.ByteString ([B.ByteString], B.ByteString) + extractPackets buf = + let buf' = until (not . B.isPrefixOf pDelim) (B.drop 2) buf in + let (bsPacket, bufTail) = B.breakSubstring pDelim buf' in + if B.null bufTail then + Left bsPacket + else + if B.null bsPacket then + Left bufTail + else + Right (B.splitWith (== '\n') bsPacket, bufTail) + + +listenLoop :: Socket -> Chan CoreMessage -> ClientIndex -> IO () +listenLoop sock chan ci = recieveWithBufferLoop B.empty + where + recieveWithBufferLoop recvBuf = do + recvBS <- recv sock 4096 + putStrLn $ show sock ++ " got smth: " ++ (show $ B.length recvBS) + unless (B.null recvBS) $ do + let (packets, newrecvBuf) = bs2Packets $ B.append recvBuf recvBS + forM_ packets sendPacket + recieveWithBufferLoop newrecvBuf + + sendPacket packet = writeChan chan $ ClientMessage (ci, packet) + + +clientRecvLoop :: Socket -> Chan CoreMessage -> ClientIndex -> IO () +clientRecvLoop s chan ci = do + msg <- (listenLoop s chan ci >> return "Connection closed") `catch` (return . B.pack . show) + clientOff msg where - clientOff msg = writeChan chan $ ClientMessage (clientID, ["QUIT", msg]) -- if the client disconnects, we perform as if it sent QUIT message - freeClient = writeChan chan $ FreeClient clientID + clientOff msg = writeChan chan $ ClientMessage (ci, ["QUIT", msg]) + -clientSendLoop :: Handle -> Chan CoreMessage -> Chan [String] -> ClientIndex -> IO() -clientSendLoop handle coreChan chan clientID = do + +clientSendLoop :: Socket -> Chan CoreMessage -> Chan [B.ByteString] -> ClientIndex -> IO() +clientSendLoop s coreChan chan ci = do answer <- readChan chan doClose <- Exception.handle (\(e :: Exception.IOException) -> if isQuit answer then return True else sendQuit e >> return False) $ do - B.hPutStrLn handle $ BUTF8.fromString $ unlines answer - hFlush handle + sendAll s $ (B.unlines answer) `B.append` (B.singleton '\n') return $ isQuit answer if doClose then - Exception.handle (\(_ :: Exception.IOException) -> putStrLn "error on hClose") $ hClose handle + Exception.handle (\(_ :: Exception.IOException) -> putStrLn "error on sClose") $ sClose s else - clientSendLoop handle coreChan chan clientID + clientSendLoop s coreChan chan ci where - sendQuit e = writeChan coreChan $ ClientMessage (clientID, ["QUIT", show e]) + sendQuit e = writeChan coreChan $ ClientMessage (ci, ["QUIT", B.pack $ show e]) isQuit ("BYE":xs) = True isQuit _ = False