# HG changeset patch
# User unc0rr
# Date 1273513686 0
# Node ID 11cd56019f00d9e025d62a2b5f6d2a0f8d262aeb
# Parent  2c29b75746f3804129269879f75d7fa7669e7f44
Make some more protocol commands work

diff -r 2c29b75746f3 -r 11cd56019f00 gameServer/Actions.hs
--- a/gameServer/Actions.hs	Mon May 10 15:31:09 2010 +0000
+++ b/gameServer/Actions.hs	Mon May 10 17:48:06 2010 +0000
@@ -1,3 +1,4 @@
+
 module Actions where
 
 import Control.Concurrent
@@ -15,13 +16,13 @@
 import CoreTypes
 import Utils
 import ClientIO
-import RoomsAndClients
+import ServerState
 
 data Action =
     AnswerClients [ClientChan] [String]
     | SendServerMessage
     | SendServerVars
-    | RoomAddThisClient Int -- roomID
+    | RoomAddThisClient RoomIndex -- roomID
     | RoomRemoveThisClient String
     | RemoveTeam String
     | RemoveRoom
@@ -30,12 +31,12 @@
     | ProtocolError String
     | Warning String
     | ByeClient String
-    | KickClient Int -- clID
-    | KickRoomClient Int -- clID
+    | KickClient ClientIndex -- clID
+    | KickRoomClient ClientIndex -- clID
     | BanClient String -- nick
-    | RemoveClientTeams Int -- clID
+    | RemoveClientTeams ClientIndex -- clID
     | ModifyClient (ClientInfo -> ClientInfo)
-    | ModifyClient2 Int (ClientInfo -> ClientInfo)
+    | ModifyClient2 ClientIndex (ClientInfo -> ClientInfo)
     | ModifyRoom (RoomInfo -> RoomInfo)
     | ModifyServerInfo (ServerInfo -> ServerInfo)
     | AddRoom String String
@@ -49,21 +50,8 @@
 
 type CmdHandler = [String] -> Reader (ClientIndex, IRnC) [Action]
 
-data ActionsState = ActionsState {
-        clientIndex :: Maybe ClientIndex,
-        serverInfo :: ServerInfo,
-        roomsClients :: MRnC
-    }
-    
-clientRoomA :: StateT ActionsState IO RoomIndex
-clientRoomA = do
-    (Just ci) <- gets clientIndex
-    rnc <- gets roomsClients
-    liftIO $ clientRoomM rnc ci
 
-replaceID a (b, c, d, e) = (a, c, d, e)
-
-processAction :: Action -> StateT ActionsState IO ()
+processAction :: Action -> StateT ServerState IO ()
 
 
 processAction (AnswerClients chans msg) = 
@@ -111,11 +99,12 @@
         processAction $ RoomRemoveThisClient ("quit: " ++ msg)
         return ()
 
+    chan <- clients sendChan
+
     liftIO $ do
         infoM "Clients" (show ci ++ " quits: " ++ msg)
 
-        chan <- withRoomsAndClients rnc (getChan ci)
-
+        
         --mapM_ (processAction (ci, serverInfo, rnc)) $ answerOthersQuit ++ answerInformRoom
         writeChan chan ["BYE", msg]
         modifyRoom rnc (\r -> r{
@@ -123,10 +112,6 @@
                         playersIn = (playersIn r) - 1
                         --readyPlayers = if isReady client then readyPlayers r - 1 else readyPlayers r
                         }) ri
-        removeClient rnc ci
-    where
-        getChan ci irnc = let cl = irnc `client` ci in (sendChan cl)
-
     
 {-
     where
@@ -149,21 +134,21 @@
             else
             [] 
 -}
-{-
 
-processAction (clID, serverInfo, rnc) (ModifyClient func) =
-    return (clID, serverInfo, adjust func clID rnc)
-
+processAction (ModifyClient f) = do
+    (Just ci) <- gets clientIndex
+    rnc <- gets roomsClients
+    liftIO $ modifyClient rnc f ci
+    return ()
+    
 
-processAction (clID, serverInfo, rnc) (ModifyClient2 cl2ID func) =
-    return (clID, serverInfo, adjust func cl2ID rnc)
-
+processAction (ModifyRoom f) = do
+    rnc <- gets roomsClients
+    ri <- clientRoomA
+    liftIO $ modifyRoom rnc f ri
+    return ()
 
-processAction (clID, serverInfo, rnc) (ModifyRoom func) =
-    return (clID, serverInfo, clients, adjust func rID rooms)
-    where
-        rID = roomID $ clients ! clID
-
+{-
 
 processAction (clID, serverInfo, rnc) (ModifyServerInfo func) =
     return (clID, func serverInfo, rnc)
@@ -308,15 +293,17 @@
         rID = roomID client
         client = clients ! clID
         rmTeamMsg = toEngineMsg $ 'F' : teamName
-
+-}
 
-processAction (clID, serverInfo, rnc) (CheckRegistered) = do
-    writeChan (dbQueries serverInfo) $ CheckAccount (clientUID client) (nick client) (host client)
-    return (clID, serverInfo, rnc)
-    where
-        client = clients ! clID
+processAction CheckRegistered = do
+    (Just ci) <- gets clientIndex
+    n <- clients nick
+    h <- clients host
+    db <- gets (dbQueries . serverInfo)
+    liftIO $ writeChan db $ CheckAccount ci n h
+    return ()
 
-
+{-
 processAction (clID, serverInfo, rnc) (ClearAccountsCache) = do
     writeChan (dbQueries serverInfo) ClearCache
     return (clID, serverInfo, rnc)
@@ -397,7 +384,7 @@
             return (ci, serverInfo)
 -}
 
-
+    
 
 
 {-
diff -r 2c29b75746f3 -r 11cd56019f00 gameServer/CMakeLists.txt
--- a/gameServer/CMakeLists.txt	Mon May 10 15:31:09 2010 +0000
+++ b/gameServer/CMakeLists.txt	Mon May 10 17:48:06 2010 +0000
@@ -18,13 +18,15 @@
     Opts.hs
     ServerCore.hs
     Utils.hs
+    RoomsAndClients.hs
+    ServerState.hs
+    Store.hs
     hedgewars-server.hs
     )
 
 set(hwserv_main ${hedgewars_SOURCE_DIR}/gameServer/hedgewars-server.hs)
 
 set(ghc_flags
-    -O2
     --make ${hwserv_main}
     -i${hedgewars_SOURCE_DIR}/gameServer
     -o ${EXECUTABLE_OUTPUT_PATH}/hedgewars-server${CMAKE_EXECUTABLE_SUFFIX}
diff -r 2c29b75746f3 -r 11cd56019f00 gameServer/ClientIO.hs
--- a/gameServer/ClientIO.hs	Mon May 10 15:31:09 2010 +0000
+++ b/gameServer/ClientIO.hs	Mon May 10 17:48:06 2010 +0000
@@ -14,22 +14,29 @@
 
 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
-        writeChan chan $ ClientMessage (clientID, ["QUIT", "Protocol violation"])
+           protocolViolationMsg >> freeClient
         else
         if str == "" then do
-            writeChan chan $ ClientMessage (clientID, buf)
+            writeChan chan $ ClientMessage (clientID, reverse buf)
             yield
             listenLoop handle 0 [] chan clientID
             else
-            listenLoop handle (linesNumber + 1) (buf ++ [str]) chan clientID
+            listenLoop handle (linesNumber + 1) (str : buf) chan clientID
+    where 
+        protocolViolationMsg = writeChan chan $ ClientMessage (clientID, ["QUIT", "Protocol violation"])
+        freeClient = writeChan chan $ FreeClient clientID
+
 
 clientRecvLoop :: Handle -> Chan CoreMessage -> ClientIndex -> 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
+        `catch` (\e -> clientOff (show e) >> freeClient >> return ())
+    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
 
 clientSendLoop :: Handle -> Chan CoreMessage -> Chan [String] -> ClientIndex -> IO()
 clientSendLoop handle coreChan chan clientID = do
diff -r 2c29b75746f3 -r 11cd56019f00 gameServer/CoreTypes.hs
--- a/gameServer/CoreTypes.hs	Mon May 10 15:31:09 2010 +0000
+++ b/gameServer/CoreTypes.hs	Mon May 10 17:48:06 2010 +0000
@@ -171,6 +171,7 @@
     | ClientMessage (ClientIndex, [String])
     | ClientAccountInfo (ClientIndex, AccountInfo)
     | TimerAction Int
+    | FreeClient ClientIndex
 
 type MRnC = MRoomsAndClients RoomInfo ClientInfo
 type IRnC = IRoomsAndClients RoomInfo ClientInfo
diff -r 2c29b75746f3 -r 11cd56019f00 gameServer/HWProtoCore.hs
--- a/gameServer/HWProtoCore.hs	Mon May 10 15:31:09 2010 +0000
+++ b/gameServer/HWProtoCore.hs	Mon May 10 17:48:06 2010 +0000
@@ -25,7 +25,7 @@
         msg = if not $ null xs then head xs else ""
 
 {-
-handleCmd clID clients _ ["PONG"] =
+handleCmd ["PONG"] =
     if pingsQueue client == 0 then
         [ProtocolError "Protocol violation"]
     else
@@ -37,9 +37,9 @@
 handleCmd cmd = do
     (ci, irnc) <- ask
     if logonPassed (irnc `client` ci) then
-        handleCmd_NotEntered cmd
+        handleCmd_loggedin cmd
         else
-        handleCmd_loggedin cmd
+        handleCmd_NotEntered cmd
 
 {-
 handleCmd_loggedin clID clients rooms ["INFO", asknick] =
diff -r 2c29b75746f3 -r 11cd56019f00 gameServer/HWProtoNEState.hs
--- a/gameServer/HWProtoNEState.hs	Mon May 10 15:31:09 2010 +0000
+++ b/gameServer/HWProtoNEState.hs	Mon May 10 17:48:06 2010 +0000
@@ -4,38 +4,46 @@
 import Maybe
 import Data.List
 import Data.Word
+import Control.Monad.Reader
 --------------------------------------
 import CoreTypes
 import Actions
 import Utils
+import RoomsAndClients
 
 handleCmd_NotEntered :: CmdHandler
 
-{-
-handleCmd_NotEntered clID clients _ ["NICK", newNick]
-    | not . null $ nick client = [ProtocolError "Nickname already chosen"]
-    | haveSameNick = [AnswerThisClient ["WARNING", "Nickname already in use"], ByeClient ""]
-    | illegalName newNick = [ByeClient "Illegal nickname"]
-    | otherwise =
-        ModifyClient (\c -> c{nick = newNick}) :
-        AnswerThisClient ["NICK", newNick] :
-        [CheckRegistered | clientProto client /= 0]
+handleCmd_NotEntered ["NICK", newNick] = do
+    (ci, irnc) <- ask
+    let cl = irnc `client` ci
+    if not . null $ nick cl then return [ProtocolError "Nickname already chosen"]
+        else
+        if haveSameNick irnc then return [AnswerClients [sendChan cl] ["WARNING", "Nickname already in use"], ByeClient ""]
+            else 
+            if illegalName newNick then return [ByeClient "Illegal nickname"]
+                else
+                return $
+                    ModifyClient (\c -> c{nick = newNick}) :
+                    AnswerClients [sendChan cl] ["NICK", newNick] :
+                    [CheckRegistered | clientProto cl /= 0]
     where
-        client = clients IntMap.! clID
-        haveSameNick = isJust $ find (\cl -> newNick == nick cl) $ IntMap.elems clients
-
+        haveSameNick irnc = False --isJust $ find (\cl -> newNick == nick cl) $ IntMap.elems clients
 
-handleCmd_NotEntered clID clients _ ["PROTO", protoNum]
-    | clientProto client > 0 = [ProtocolError "Protocol already known"]
-    | parsedProto == 0 = [ProtocolError "Bad number"]
-    | otherwise =
-        ModifyClient (\c -> c{clientProto = parsedProto}) :
-        AnswerThisClient ["PROTO", show parsedProto] :
-        [CheckRegistered | (not . null) (nick client)]
+handleCmd_NotEntered ["PROTO", protoNum] = do
+    (ci, irnc) <- ask
+    let cl = irnc `client` ci
+    if clientProto cl > 0 then return [ProtocolError "Protocol already known"]
+        else 
+        if parsedProto == 0 then return [ProtocolError "Bad number"]
+            else 
+            return $
+                ModifyClient (\c -> c{clientProto = parsedProto}) :
+                AnswerClients [sendChan cl] ["PROTO", show parsedProto] :
+                [CheckRegistered | (not . null) (nick cl)]
     where
-        client = clients IntMap.! clID
         parsedProto = fromMaybe 0 (maybeRead protoNum :: Maybe Word16)
 
+{-
 
 handleCmd_NotEntered clID clients _ ["PASSWORD", passwd] =
     if passwd == webPassword client then
diff -r 2c29b75746f3 -r 11cd56019f00 gameServer/RoomsAndClients.hs
--- a/gameServer/RoomsAndClients.hs	Mon May 10 15:31:09 2010 +0000
+++ b/gameServer/RoomsAndClients.hs	Mon May 10 17:48:06 2010 +0000
@@ -16,6 +16,7 @@
     clientRoom,
     clientRoomM,
     client,
+    clientsM,
     allClients,
     withRoomsAndClients,
     showRooms,
@@ -135,6 +136,9 @@
 clientRoomM :: MRoomsAndClients r c -> ClientIndex -> IO RoomIndex
 clientRoomM (MRoomsAndClients (_, clients)) (ClientIndex ci) = liftM clientRoom' (clients `readElem` ci)
 
+clientsM :: MRoomsAndClients r c -> (c -> a) -> ClientIndex -> IO a
+clientsM (MRoomsAndClients (_, clients)) f (ClientIndex ci) = liftM (f . client') (clients `readElem` ci)
+
 
 withRoomsAndClients :: MRoomsAndClients r c -> (IRoomsAndClients r c -> a) -> IO a
 withRoomsAndClients (MRoomsAndClients (rooms, clients)) f =
diff -r 2c29b75746f3 -r 11cd56019f00 gameServer/ServerCore.hs
--- a/gameServer/ServerCore.hs	Mon May 10 15:31:09 2010 +0000
+++ b/gameServer/ServerCore.hs	Mon May 10 17:48:06 2010 +0000
@@ -14,21 +14,21 @@
 import HWProtoCore
 import Actions
 import OfficialServer.DBInteraction
-import RoomsAndClients
+import ServerState
 
 
 timerLoop :: Int -> Chan CoreMessage -> IO()
 timerLoop tick messagesChan = threadDelay (30 * 10^6) >> writeChan messagesChan (TimerAction tick) >> timerLoop (tick + 1) messagesChan
 
 
-reactCmd :: [String] -> StateT ActionsState IO ()
+reactCmd :: [String] -> StateT ServerState IO ()
 reactCmd cmd = do
     (Just ci) <- gets clientIndex
     rnc <- gets roomsClients
     actions <- liftIO $ withRoomsAndClients rnc (\irnc -> runReader (handleCmd cmd) (ci, irnc))
     forM_ actions processAction
 
-mainLoop :: StateT ActionsState IO ()
+mainLoop :: StateT ServerState IO ()
 mainLoop = forever $ do
     si <- gets serverInfo
     r <- liftIO $ readChan $ coreChan si
@@ -64,6 +64,11 @@
             --    foldM processAction (0, serverInfo, rnc) $
             --        PingAll : [StatsAction | even tick]
 
+        FreeClient ci -> do
+            rnc <- gets roomsClients
+            liftIO $ removeClient rnc ci
+
+
 startServer :: ServerInfo -> Socket -> IO ()
 startServer serverInfo serverSocket = do
     putStrLn $ "Listening on port " ++ show (listenPort serverInfo)
@@ -81,6 +86,6 @@
 
     rnc <- newRoomsAndClients newRoom
 
-    forkIO $ evalStateT mainLoop (ActionsState Nothing serverInfo rnc)
+    forkIO $ evalStateT mainLoop (ServerState Nothing serverInfo rnc)
 
     forever $ threadDelay (60 * 60 * 10^6) >> putStrLn "***"
diff -r 2c29b75746f3 -r 11cd56019f00 gameServer/ServerState.hs
--- /dev/null	Thu Jan 01 00:00:00 1970 +0000
+++ b/gameServer/ServerState.hs	Mon May 10 17:48:06 2010 +0000
@@ -0,0 +1,32 @@
+module ServerState
+    (
+    module RoomsAndClients,
+    clientRoomA,
+    ServerState(..),
+    clients
+    ) where
+
+import Control.Monad.State
+----------------------
+import RoomsAndClients
+import CoreTypes
+
+data ServerState = ServerState {
+        clientIndex :: Maybe ClientIndex,
+        serverInfo :: ServerInfo,
+        roomsClients :: MRnC
+    }
+
+
+clientRoomA :: StateT ServerState IO RoomIndex
+clientRoomA = do
+    (Just ci) <- gets clientIndex
+    rnc <- gets roomsClients
+    liftIO $ clientRoomM rnc ci
+
+clients :: (ClientInfo -> a) -> StateT ServerState IO a
+clients f = do
+    (Just ci) <- gets clientIndex
+    rnc <- gets roomsClients
+    liftIO $ clientsM rnc f ci
+    
\ No newline at end of file