gameServer/ClientIO.hs
changeset 4588 5ef5415c4ee1
parent 4570 fa19f0579083
child 4904 0eab727d4717
--- a/gameServer/ClientIO.hs	Tue Dec 14 22:32:47 2010 +0100
+++ b/gameServer/ClientIO.hs	Thu Dec 23 17:47:50 2010 +0100
@@ -1,4 +1,4 @@
-{-# LANGUAGE ScopedTypeVariables, OverloadedStrings #-}
+{-# LANGUAGE ScopedTypeVariables #-}
 module ClientIO where
 
 import qualified Control.Exception as Exception
@@ -6,71 +6,45 @@
 import Control.Concurrent
 import Control.Monad
 import System.IO
-import Network
-import Network.Socket.ByteString
-import qualified Data.ByteString.Char8 as B
+import qualified Data.ByteString.UTF8 as BUTF8
+import qualified Data.ByteString as B
 ----------------
 import CoreTypes
-import RoomsAndClients
-import Utils
 
-
-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 :: Handle -> Int -> [String] -> Chan CoreMessage -> Int -> IO ()
+listenLoop handle linesNumber buf chan clientID = do
+    str <- liftM BUTF8.toString $ B.hGetLine handle
+    if (linesNumber > 50) || (length str > 20000) then
+        writeChan chan $ ClientMessage (clientID, ["QUIT", "Protocol violation"])
+        else
+        if str == "" then do
+            writeChan chan $ ClientMessage (clientID, buf)
+            yield
+            listenLoop handle 0 [] chan clientID
+            else
+            listenLoop handle (linesNumber + 1) (buf ++ [str]) chan clientID
 
-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 :: Handle -> Chan CoreMessage -> Int -> IO ()
+clientRecvLoop handle chan clientID =
+    listenLoop handle 0 [] chan clientID
+        `catch` (\e -> clientOff (show e) >> return ())
+    where clientOff msg = writeChan chan $ ClientMessage (clientID, ["QUIT", msg]) -- if the client disconnects, we perform as if it sent QUIT message
 
-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 = mapM_ (writeChan chan) [ClientMessage (ci, ["QUIT", msg]), Remove ci]
-
-
+clientSendLoop :: Handle -> Chan CoreMessage -> Chan [String] -> Int -> IO()
+clientSendLoop handle coreChan chan clientID = 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
+            return $ isQuit answer
 
-clientSendLoop :: Socket -> Chan [B.ByteString] -> ClientIndex -> IO ()
-clientSendLoop s chan ci = do
-    answer <- readChan chan
-    Exception.handle
-        (\(e :: Exception.IOException) -> when (not $ isQuit answer) $ sendQuit e) $ do
-            sendAll s $ (B.unlines answer) `B.append` (B.singleton '\n')
-
-    if (isQuit answer) then
-        Exception.handle (\(_ :: Exception.IOException) -> putStrLn "error on sClose") $ sClose s
+    if doClose then
+        Exception.handle (\(_ :: Exception.IOException) -> putStrLn "error on hClose") $ hClose handle
         else
-        clientSendLoop s chan ci
+        clientSendLoop handle coreChan chan clientID
 
     where
-        --sendQuit e = writeChan coreChan $ ClientMessage (ci, ["QUIT", B.pack $ show e])
-        sendQuit e = putStrLn $ show e
+        sendQuit e = writeChan coreChan $ ClientMessage (clientID, ["QUIT", show e])
         isQuit ("BYE":xs) = True
         isQuit _ = False