|
1 {- |
|
2 * Hedgewars, a free turn based strategy game |
|
3 * Copyright (c) 2004-2015 Andrey Korotaev <unC0Rr@gmail.com> |
|
4 * |
|
5 * This program is free software; you can redistribute it and/or modify |
|
6 * it under the terms of the GNU General Public License as published by |
|
7 * the Free Software Foundation; version 2 of the License |
|
8 * |
|
9 * This program is distributed in the hope that it will be useful, |
|
10 * but WITHOUT ANY WARRANTY; without even the implied warranty of |
|
11 * MERCHANTABILITY or FITNESS FOR A PARTICULAR PURPOSE. See the |
|
12 * GNU General Public License for more details. |
|
13 * |
|
14 * You should have received a copy of the GNU General Public License |
|
15 * along with this program; if not, write to the Free Software |
|
16 * Foundation, Inc., 51 Franklin Street, Fifth Floor, Boston, MA 02110-1301 USA. |
|
17 \-} |
|
18 |
1 module ServerCore where |
19 module ServerCore where |
2 |
20 |
3 import Control.Concurrent |
21 import Control.Concurrent |
4 import Control.Monad |
22 import Control.Monad |
5 import System.Log.Logger |
23 import System.Log.Logger |
6 import Control.Monad.Reader |
24 import Control.Monad.Reader |
7 import Control.Monad.State.Strict |
25 import Control.Monad.State.Strict |
8 import Data.Set as Set |
26 import Data.Set as Set hiding (null) |
9 import qualified Data.ByteString.Char8 as B |
|
10 import Control.DeepSeq |
|
11 import Data.Unique |
27 import Data.Unique |
12 import Data.Maybe |
28 import Data.Maybe |
13 -------------------------------------- |
29 -------------------------------------- |
14 import CoreTypes |
30 import CoreTypes |
15 import NetRoutines |
31 import NetRoutines |
16 import HWProtoCore |
|
17 import Actions |
32 import Actions |
18 import OfficialServer.DBInteraction |
33 import OfficialServer.DBInteraction |
19 import ServerState |
34 import ServerState |
20 |
35 |
21 |
36 |
22 timerLoop :: Int -> Chan CoreMessage -> IO () |
37 timerLoop :: Int -> Chan CoreMessage -> IO () |
23 timerLoop tick messagesChan = threadDelay 30000000 >> writeChan messagesChan (TimerAction tick) >> timerLoop (tick + 1) messagesChan |
38 timerLoop tick messagesChan = threadDelay 30000000 >> writeChan messagesChan (TimerAction tick) >> timerLoop (tick + 1) messagesChan |
24 |
39 |
25 |
|
26 reactCmd :: [B.ByteString] -> StateT ServerState IO () |
|
27 reactCmd cmd = do |
|
28 (Just ci) <- gets clientIndex |
|
29 rnc <- gets roomsClients |
|
30 actions <- liftIO $ withRoomsAndClients rnc (\irnc -> runReader (handleCmd cmd) (ci, irnc)) |
|
31 forM_ (actions `deepseq` actions) processAction |
|
32 |
40 |
33 mainLoop :: StateT ServerState IO () |
41 mainLoop :: StateT ServerState IO () |
34 mainLoop = forever $ do |
42 mainLoop = forever $ do |
35 -- get >>= \s -> put $! s |
43 -- get >>= \s -> put $! s |
36 |
44 |
44 liftIO $ debugM "Clients" $ show ci ++ ": " ++ show cmd |
52 liftIO $ debugM "Clients" $ show ci ++ ": " ++ show cmd |
45 |
53 |
46 removed <- gets removedClients |
54 removed <- gets removedClients |
47 unless (ci `Set.member` removed) $ do |
55 unless (ci `Set.member` removed) $ do |
48 modify (\s -> s{clientIndex = Just ci}) |
56 modify (\s -> s{clientIndex = Just ci}) |
49 reactCmd cmd |
57 processAction $ ReactCmd cmd |
|
58 pa <- client's pendingActions |
|
59 when (not $ null pa) $ do |
|
60 mapM_ processAction pa |
|
61 processAction $ ModifyClient $ \c -> c{pendingActions = []} |
50 |
62 |
51 Remove ci -> |
63 Remove ci -> |
52 processAction (DeleteClient ci) |
64 processAction (DeleteClient ci) |
53 |
65 |
54 ClientAccountInfo ci uid info -> do |
66 ClientAccountInfo ci uid info -> do |