equal
deleted
inserted
replaced
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 |
5 import Control.Concurrent.Chan |
7 import Control.Monad |
6 import Control.Monad |
8 import qualified Data.IntMap as IntMap |
7 import qualified Data.IntMap as IntMap |
9 import System.Log.Logger |
8 import System.Log.Logger |
10 -------------------------------------- |
9 -------------------------------------- |
11 import CoreTypes |
10 import CoreTypes |
12 import NetRoutines |
11 import NetRoutines |
13 import Utils |
|
14 import HWProtoCore |
12 import HWProtoCore |
15 import Actions |
13 import Actions |
16 import OfficialServer.DBInteraction |
14 import OfficialServer.DBInteraction |
17 |
15 |
18 |
16 |
26 liftM firstAway $ foldM processAction (clID, serverInfo, clients, rooms) $ handleCmd clID clients rooms cmd |
24 liftM firstAway $ foldM processAction (clID, serverInfo, clients, rooms) $ handleCmd clID clients rooms cmd |
27 |
25 |
28 mainLoop :: ServerInfo -> Clients -> Rooms -> IO () |
26 mainLoop :: ServerInfo -> Clients -> Rooms -> IO () |
29 mainLoop serverInfo clients rooms = do |
27 mainLoop serverInfo clients rooms = do |
30 r <- readChan $ coreChan serverInfo |
28 r <- readChan $ coreChan serverInfo |
31 |
29 |
32 (newServerInfo, mClients, mRooms) <- |
30 (newServerInfo, mClients, mRooms) <- |
33 case r of |
31 case r of |
34 Accept ci -> |
32 Accept ci -> |
35 liftM firstAway $ processAction |
33 liftM firstAway $ processAction |
36 (clientUID ci, serverInfo, clients, rooms) (AddClient ci) |
34 (clientUID ci, serverInfo, clients, rooms) (AddClient ci) |
57 TimerAction tick -> |
55 TimerAction tick -> |
58 liftM firstAway $ |
56 liftM firstAway $ |
59 foldM processAction (0, serverInfo, clients, rooms) $ |
57 foldM processAction (0, serverInfo, clients, rooms) $ |
60 PingAll : [StatsAction | even tick] |
58 PingAll : [StatsAction | even tick] |
61 |
59 |
62 |
|
63 {- let hadRooms = (not $ null rooms) && (null mrooms) |
|
64 in unless ((not $ isDedicated serverInfo) && ((null clientsIn) || hadRooms)) $ |
|
65 mainLoop serverInfo acceptChan messagesChan clientsIn mrooms -} |
|
66 |
|
67 mainLoop newServerInfo mClients mRooms |
60 mainLoop newServerInfo mClients mRooms |
68 |
61 |
69 startServer :: ServerInfo -> Socket -> IO () |
62 startServer :: ServerInfo -> Socket -> IO () |
70 startServer serverInfo serverSocket = do |
63 startServer serverInfo serverSocket = do |
71 putStrLn $ "Listening on port " ++ show (listenPort serverInfo) |
64 putStrLn $ "Listening on port " ++ show (listenPort serverInfo) |