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 |