gameServer/ServerCore.hs
author nemo
Sun, 20 Jun 2010 19:31:15 -0400
changeset 3524 8d0783d2a0ff
parent 3500 af8390d807d6
child 3566 772a46ef8288
permissions -rw-r--r--
This reduces CheckLand ~5.5% on average over prior making the overall reduction ~77.4% instead of ~81.9%. It does skip centre pixel in odd w/h, but that really shouldn't matter much in this case. Can alter if any objects are noticeably off.

module ServerCore where

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


timerLoop :: Int -> Chan CoreMessage -> IO()
timerLoop tick messagesChan = threadDelay (30 * 10^6) >> 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 processAction

mainLoop :: StateT ServerState IO ()
mainLoop = forever $ do
    si <- gets serverInfo
    r <- liftIO $ readChan $ coreChan si

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

        ClientMessage (ci, cmd) -> do
            liftIO $ debugM "Clients" $ (show ci) ++ ": " ++ (show cmd)
            modify (\as -> as{clientIndex = Just ci})
            --if clID `IntMap.member` clients then
            reactCmd cmd
            return ()
                --else
                --do
                --debugM "Clients" "Message from dead client"
                --return (serverInfo, rnc)

        ClientAccountInfo (clID, info) -> do
            --if clID `IntMap.member` clients then
            processAction (ProcessAccountInfo info)
            return ()
                --else
                --do
                --debugM "Clients" "Got info for dead client"
                --return (serverInfo, rnc)

        TimerAction tick ->
            return ()
            --liftM snd $
            --    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)

    forkIO $
        acceptLoop
            serverSocket
            (coreChan serverInfo)

    return ()

    forkIO $ timerLoop 0 $ coreChan serverInfo

    startDBConnection serverInfo

    rnc <- newRoomsAndClients newRoom

    forkIO $ evalStateT mainLoop (ServerState Nothing serverInfo rnc)

    forever $ threadDelay (60 * 60 * 10^6) >> putStrLn "***"