4 import Control.Concurrent |
4 import Control.Concurrent |
5 import Control.Concurrent.Chan |
5 import Control.Concurrent.Chan |
6 import Control.Monad |
6 import Control.Monad |
7 import qualified Data.IntMap as IntMap |
7 import qualified Data.IntMap as IntMap |
8 import System.Log.Logger |
8 import System.Log.Logger |
|
9 import Control.Monad.Reader |
9 -------------------------------------- |
10 -------------------------------------- |
10 import CoreTypes |
11 import CoreTypes |
11 import NetRoutines |
12 import NetRoutines |
12 import HWProtoCore |
13 import HWProtoCore |
13 import Actions |
14 import Actions |
14 import OfficialServer.DBInteraction |
15 import OfficialServer.DBInteraction |
|
16 import RoomsAndClients |
15 |
17 |
16 |
18 |
17 timerLoop :: Int -> Chan CoreMessage -> IO() |
19 timerLoop :: Int -> Chan CoreMessage -> IO() |
18 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 |
19 |
21 |
20 firstAway (_, a, b, c) = (a, b, c) |
|
21 |
22 |
22 reactCmd :: ServerInfo -> Int -> [String] -> Clients -> Rooms -> IO (ServerInfo, Clients, Rooms) |
23 reactCmd :: ServerInfo -> ClientIndex -> [String] -> MRnC -> IO () |
23 reactCmd serverInfo clID cmd clients rooms = |
24 reactCmd sInfo ci cmd rnc = do |
24 liftM firstAway $ foldM processAction (clID, serverInfo, clients, rooms) $ handleCmd clID clients rooms cmd |
25 actions <- withRoomsAndClients rnc (\irnc -> runReader (handleCmd cmd) (ci, irnc)) |
|
26 forM_ actions (processAction (ci, sInfo, rnc)) |
25 |
27 |
26 mainLoop :: ServerInfo -> Clients -> Rooms -> IO () |
28 mainLoop :: ServerInfo -> MRnC -> IO () |
27 mainLoop serverInfo clients rooms = do |
29 mainLoop serverInfo rnc = forever $ do |
28 r <- readChan $ coreChan serverInfo |
30 r <- readChan $ coreChan serverInfo |
29 |
31 |
30 (newServerInfo, mClients, mRooms) <- |
32 case r of |
31 case r of |
33 Accept ci -> do |
32 Accept ci -> |
34 processAction |
33 liftM firstAway $ processAction |
35 (undefined, serverInfo, rnc) (AddClient ci) |
34 (clientUID ci, serverInfo, clients, rooms) (AddClient ci) |
36 return () |
35 |
37 |
36 ClientMessage (clID, cmd) -> do |
38 ClientMessage (clID, cmd) -> do |
37 debugM "Clients" $ (show clID) ++ ": " ++ (show cmd) |
39 debugM "Clients" $ (show clID) ++ ": " ++ (show cmd) |
38 if clID `IntMap.member` clients then |
40 --if clID `IntMap.member` clients then |
39 reactCmd serverInfo clID cmd clients rooms |
41 reactCmd serverInfo clID cmd rnc |
40 else |
42 return () |
41 do |
43 --else |
42 debugM "Clients" "Message from dead client" |
44 --do |
43 return (serverInfo, clients, rooms) |
45 --debugM "Clients" "Message from dead client" |
|
46 --return (serverInfo, rnc) |
44 |
47 |
45 ClientAccountInfo (clID, info) -> |
48 ClientAccountInfo (clID, info) -> do |
46 if clID `IntMap.member` clients then |
49 --if clID `IntMap.member` clients then |
47 liftM firstAway $ processAction |
50 processAction |
48 (clID, serverInfo, clients, rooms) |
51 (clID, serverInfo, rnc) |
49 (ProcessAccountInfo info) |
52 (ProcessAccountInfo info) |
50 else |
53 return () |
51 do |
54 --else |
52 debugM "Clients" "Got info for dead client" |
55 --do |
53 return (serverInfo, clients, rooms) |
56 --debugM "Clients" "Got info for dead client" |
|
57 --return (serverInfo, rnc) |
54 |
58 |
55 TimerAction tick -> |
59 TimerAction tick -> |
56 liftM firstAway $ |
60 return () |
57 foldM processAction (0, serverInfo, clients, rooms) $ |
61 --liftM snd $ |
58 PingAll : [StatsAction | even tick] |
62 -- foldM processAction (0, serverInfo, rnc) $ |
59 |
63 -- PingAll : [StatsAction | even tick] |
60 mainLoop newServerInfo mClients mRooms |
|
61 |
64 |
62 startServer :: ServerInfo -> Socket -> IO () |
65 startServer :: ServerInfo -> Socket -> IO () |
63 startServer serverInfo serverSocket = do |
66 startServer serverInfo serverSocket = do |
64 putStrLn $ "Listening on port " ++ show (listenPort serverInfo) |
67 putStrLn $ "Listening on port " ++ show (listenPort serverInfo) |
65 |
68 |
66 forkIO $ |
69 forkIO $ |
67 acceptLoop |
70 acceptLoop |
68 serverSocket |
71 serverSocket |
69 (coreChan serverInfo) |
72 (coreChan serverInfo) |
70 0 |
|
71 |
73 |
72 return () |
74 return () |
73 |
75 |
74 forkIO $ timerLoop 0 $ coreChan serverInfo |
76 forkIO $ timerLoop 0 $ coreChan serverInfo |
75 |
77 |
76 startDBConnection serverInfo |
78 startDBConnection serverInfo |
77 |
79 |
78 forkIO $ mainLoop serverInfo IntMap.empty (IntMap.singleton 0 newRoom) |
80 rnc <- newRoomsAndClients newRoom |
|
81 |
|
82 forkIO $ mainLoop serverInfo rnc |
79 |
83 |
80 forever $ threadDelay (60 * 60 * 10^6) >> putStrLn "***" |
84 forever $ threadDelay (60 * 60 * 10^6) >> putStrLn "***" |