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