gameServer/ServerCore.hs
changeset 4904 0eab727d4717
parent 4568 f85243bf890e
parent 4612 e82758d6f924
child 4918 c6d3aec73f93
equal deleted inserted replaced
4903:21dd1def5aaf 4904:0eab727d4717
     1 module ServerCore where
     1 module ServerCore where
     2 
     2 
     3 import Network
     3 import Network
     4 import Control.Concurrent
     4 import Control.Concurrent
     5 import Control.Concurrent.STM
       
     6 import Control.Concurrent.Chan
       
     7 import Control.Monad
     5 import Control.Monad
     8 import qualified Data.IntMap as IntMap
       
     9 import System.Log.Logger
     6 import System.Log.Logger
       
     7 import Control.Monad.Reader
       
     8 import Control.Monad.State.Strict
       
     9 import Data.Set as Set
       
    10 import qualified Data.ByteString.Char8 as B
       
    11 import Control.DeepSeq
    10 --------------------------------------
    12 --------------------------------------
    11 import CoreTypes
    13 import CoreTypes
    12 import NetRoutines
    14 import NetRoutines
    13 import Utils
       
    14 import HWProtoCore
    15 import HWProtoCore
    15 import Actions
    16 import Actions
    16 import OfficialServer.DBInteraction
    17 import OfficialServer.DBInteraction
       
    18 import ServerState
    17 
    19 
    18 
    20 
    19 timerLoop :: Int -> Chan CoreMessage -> IO()
    21 timerLoop :: Int -> Chan CoreMessage -> IO ()
    20 timerLoop tick messagesChan = threadDelay (30 * 10^6) >> writeChan messagesChan (TimerAction tick) >> timerLoop (tick + 1) messagesChan
    22 timerLoop tick messagesChan = threadDelay 30000000 >> writeChan messagesChan (TimerAction tick) >> timerLoop (tick + 1) messagesChan
    21 
       
    22 firstAway (_, a, b, c) = (a, b, c)
       
    23 
       
    24 reactCmd :: ServerInfo -> Int -> [String] -> Clients -> Rooms -> IO (ServerInfo, Clients, Rooms)
       
    25 reactCmd serverInfo clID cmd clients rooms =
       
    26     liftM firstAway $ foldM processAction (clID, serverInfo, clients, rooms) $ handleCmd clID clients rooms cmd
       
    27 
       
    28 mainLoop :: ServerInfo -> Clients -> Rooms -> IO ()
       
    29 mainLoop serverInfo clients rooms = do
       
    30     r <- readChan $ coreChan serverInfo
       
    31     
       
    32     (newServerInfo, mClients, mRooms) <-
       
    33         case r of
       
    34             Accept ci ->
       
    35                 liftM firstAway $ processAction
       
    36                     (clientUID ci, serverInfo, clients, rooms) (AddClient ci)
       
    37 
       
    38             ClientMessage (clID, cmd) -> do
       
    39                 debugM "Clients" $ (show clID) ++ ": " ++ (show cmd)
       
    40                 if clID `IntMap.member` clients then
       
    41                     reactCmd serverInfo clID cmd clients rooms
       
    42                     else
       
    43                     do
       
    44                     debugM "Clients" "Message from dead client"
       
    45                     return (serverInfo, clients, rooms)
       
    46 
       
    47             ClientAccountInfo (clID, info) ->
       
    48                 if clID `IntMap.member` clients then
       
    49                     liftM firstAway $ processAction
       
    50                         (clID, serverInfo, clients, rooms)
       
    51                         (ProcessAccountInfo info)
       
    52                     else
       
    53                     do
       
    54                     debugM "Clients" "Got info for dead client"
       
    55                     return (serverInfo, clients, rooms)
       
    56 
       
    57             TimerAction tick ->
       
    58                 liftM firstAway $
       
    59                     foldM processAction (0, serverInfo, clients, rooms) $
       
    60                         PingAll : [StatsAction | even tick]
       
    61 
    23 
    62 
    24 
    63     {-          let hadRooms = (not $ null rooms) && (null mrooms)
    25 reactCmd :: [B.ByteString] -> StateT ServerState IO ()
    64                     in unless ((not $ isDedicated serverInfo) && ((null clientsIn) || hadRooms)) $
    26 reactCmd cmd = do
    65                         mainLoop serverInfo acceptChan messagesChan clientsIn mrooms -}
    27     (Just ci) <- gets clientIndex
       
    28     rnc <- gets roomsClients
       
    29     actions <- liftIO $ withRoomsAndClients rnc (\irnc -> runReader (handleCmd cmd) (ci, irnc))
       
    30     forM_ (actions `deepseq` actions) processAction
    66 
    31 
    67     mainLoop newServerInfo mClients mRooms
    32 mainLoop :: StateT ServerState IO ()
       
    33 mainLoop = forever $ do
       
    34     get >>= \s -> put $! s
       
    35 
       
    36     si <- gets serverInfo
       
    37     r <- liftIO $ readChan $ coreChan si
       
    38 
       
    39     case r of
       
    40         Accept ci -> processAction (AddClient ci)
       
    41 
       
    42         ClientMessage (ci, cmd) -> do
       
    43             liftIO $ debugM "Clients" $ (show ci) ++ ": " ++ (show cmd)
       
    44 
       
    45             removed <- gets removedClients
       
    46             when (not $ ci `Set.member` removed) $ do
       
    47                 as <- get
       
    48                 put $! as{clientIndex = Just ci}
       
    49                 reactCmd cmd
       
    50 
       
    51         Remove ci -> do
       
    52             liftIO $ debugM "Clients"  $ "DeleteClient: " ++ show ci
       
    53             processAction (DeleteClient ci)
       
    54 
       
    55                 --else
       
    56                 --do
       
    57                 --debugM "Clients" "Message from dead client"
       
    58                 --return (serverInfo, rnc)
       
    59 
       
    60         ClientAccountInfo (ci, info) -> do
       
    61             rnc <- gets roomsClients
       
    62             exists <- liftIO $ clientExists rnc ci
       
    63             when (exists) $ do
       
    64                 as <- get
       
    65                 put $! as{clientIndex = Just ci}
       
    66                 processAction (ProcessAccountInfo info)
       
    67                 return ()
       
    68 
       
    69         TimerAction tick ->
       
    70                 mapM_ processAction $
       
    71                     PingAll : [StatsAction | even tick]
       
    72 
    68 
    73 
    69 startServer :: ServerInfo -> Socket -> IO ()
    74 startServer :: ServerInfo -> Socket -> IO ()
    70 startServer serverInfo serverSocket = do
    75 startServer si serverSocket = do
    71     putStrLn $ "Listening on port " ++ show (listenPort serverInfo)
    76     putStrLn $ "Listening on port " ++ show (listenPort si)
    72 
    77 
    73     forkIO $
    78     forkIO $
    74         acceptLoop
    79         acceptLoop
    75             serverSocket
    80             serverSocket
    76             (coreChan serverInfo)
    81             (coreChan si)
    77             0
       
    78 
    82 
    79     return ()
    83     return ()
    80     
       
    81     forkIO $ timerLoop 0 $ coreChan serverInfo
       
    82 
    84 
    83     startDBConnection serverInfo
    85     forkIO $ timerLoop 0 $ coreChan si
    84 
    86 
    85     forkIO $ mainLoop serverInfo IntMap.empty (IntMap.singleton 0 newRoom)
    87     startDBConnection si
    86 
    88 
    87     forever $ threadDelay (60 * 60 * 10^6) >> putStrLn "***"
    89     rnc <- newRoomsAndClients newRoom
       
    90 
       
    91     forkIO $ evalStateT mainLoop (ServerState Nothing si Set.empty rnc)
       
    92 
       
    93     forever $ threadDelay 3600000000 -- one hour