gameServer/ServerCore.hs
author smxx
Fri, 07 May 2010 13:04:01 +0000
changeset 3446 1be74e601960
parent 3435 4e4f88a7bdf2
child 3451 62089ccec75c
permissions -rw-r--r--
Graphics: * Added a team colored tophat as a "fixed colors with tinted areas" example

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 CoreTypes
import NetRoutines
import HWProtoCore
import Actions
import OfficialServer.DBInteraction
import RoomsAndClients


timerLoop :: Int -> Chan CoreMessage -> IO()
timerLoop tick messagesChan = threadDelay (30 * 10^6) >> writeChan messagesChan (TimerAction tick) >> timerLoop (tick + 1) messagesChan


reactCmd :: ServerInfo -> ClientIndex -> [String] -> MRnC -> IO ()
reactCmd sInfo ci cmd rnc = do
    actions <- withRoomsAndClients rnc (\irnc -> runReader (handleCmd cmd) (ci, irnc))
    forM_ actions (processAction (ci, sInfo, rnc))

mainLoop :: ServerInfo -> MRnC -> IO ()
mainLoop serverInfo rnc = forever $ do
    r <- readChan $ coreChan serverInfo

    case r of
        Accept ci -> do
            processAction
                (undefined, serverInfo, rnc) (AddClient ci)
            return ()

        ClientMessage (clID, cmd) -> do
            debugM "Clients" $ (show clID) ++ ": " ++ (show cmd)
            --if clID `IntMap.member` clients then
            reactCmd serverInfo clID cmd rnc
            return ()
                --else
                --do
                --debugM "Clients" "Message from dead client"
                --return (serverInfo, rnc)

        ClientAccountInfo (clID, info) -> do
            --if clID `IntMap.member` clients then
            processAction
                (clID, serverInfo, rnc)
                (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]

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 $ mainLoop serverInfo rnc

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