Henek adds a flamethrower, updates some translations, and tweaks how fire works.
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 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 :: [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 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 "***"