gameServer/ServerCore.hs
author unc0rr
Sat, 05 Feb 2011 11:32:15 +0300
changeset 4918 c6d3aec73f93
parent 4904 0eab727d4717
child 4932 f11d80bac7ed
permissions -rw-r--r--
Add Unique field to Client structure, and use it to check for matching recieved account status with client

module ServerCore where

import Network
import Control.Concurrent
import Control.Monad
import System.Log.Logger
import Control.Monad.Reader
import Control.Monad.State.Strict
import Data.Set as Set
import qualified Data.ByteString.Char8 as B
import Control.DeepSeq
import Data.Unique
--------------------------------------
import CoreTypes
import NetRoutines
import HWProtoCore
import Actions
import OfficialServer.DBInteraction
import ServerState


timerLoop :: Int -> Chan CoreMessage -> IO ()
timerLoop tick messagesChan = threadDelay 30000000 >> writeChan messagesChan (TimerAction tick) >> timerLoop (tick + 1) messagesChan


reactCmd :: [B.ByteString] -> 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 `deepseq` actions) processAction

mainLoop :: StateT ServerState IO ()
mainLoop = forever $ do
    get >>= \s -> put $! s

    si <- gets serverInfo
    r <- liftIO $ readChan $ coreChan si

    case r of
        Accept ci -> processAction (AddClient ci)

        ClientMessage (ci, cmd) -> do
            liftIO $ debugM "Clients" $ (show ci) ++ ": " ++ (show cmd)

            removed <- gets removedClients
            when (not $ ci `Set.member` removed) $ do
                as <- get
                put $! as{clientIndex = Just ci}
                reactCmd cmd

        Remove ci -> do
            liftIO $ debugM "Clients"  $ "DeleteClient: " ++ show ci
            processAction (DeleteClient ci)

                --else
                --do
                --debugM "Clients" "Message from dead client"
                --return (serverInfo, rnc)

        ClientAccountInfo ci uid info -> do
            rnc <- gets roomsClients
            exists <- liftIO $ clientExists rnc ci
            when (exists) $ do
                as <- get
                put $! as{clientIndex = Just ci}
                uid' <- client's clUID
                when (uid == (hashUnique uid')) $ processAction (ProcessAccountInfo info)
                return ()

        TimerAction tick ->
                mapM_ processAction $
                    PingAll : [StatsAction | even tick]


startServer :: ServerInfo -> Socket -> IO ()
startServer si serverSocket = do
    putStrLn $ "Listening on port " ++ show (listenPort si)

    forkIO $
        acceptLoop
            serverSocket
            (coreChan si)

    return ()

    forkIO $ timerLoop 0 $ coreChan si

    startDBConnection si

    rnc <- newRoomsAndClients newRoom

    forkIO $ evalStateT mainLoop (ServerState Nothing si Set.empty rnc)

    forever $ threadDelay 3600000000 -- one hour