equal
deleted
inserted
replaced
12 import CoreTypes |
12 import CoreTypes |
13 import NetRoutines |
13 import NetRoutines |
14 import HWProtoCore |
14 import HWProtoCore |
15 import Actions |
15 import Actions |
16 import OfficialServer.DBInteraction |
16 import OfficialServer.DBInteraction |
17 import RoomsAndClients |
17 import ServerState |
18 |
18 |
19 |
19 |
20 timerLoop :: Int -> Chan CoreMessage -> IO() |
20 timerLoop :: Int -> Chan CoreMessage -> IO() |
21 timerLoop tick messagesChan = threadDelay (30 * 10^6) >> writeChan messagesChan (TimerAction tick) >> timerLoop (tick + 1) messagesChan |
21 timerLoop tick messagesChan = threadDelay (30 * 10^6) >> writeChan messagesChan (TimerAction tick) >> timerLoop (tick + 1) messagesChan |
22 |
22 |
23 |
23 |
24 reactCmd :: [String] -> StateT ActionsState IO () |
24 reactCmd :: [String] -> StateT ServerState IO () |
25 reactCmd cmd = do |
25 reactCmd cmd = do |
26 (Just ci) <- gets clientIndex |
26 (Just ci) <- gets clientIndex |
27 rnc <- gets roomsClients |
27 rnc <- gets roomsClients |
28 actions <- liftIO $ withRoomsAndClients rnc (\irnc -> runReader (handleCmd cmd) (ci, irnc)) |
28 actions <- liftIO $ withRoomsAndClients rnc (\irnc -> runReader (handleCmd cmd) (ci, irnc)) |
29 forM_ actions processAction |
29 forM_ actions processAction |
30 |
30 |
31 mainLoop :: StateT ActionsState IO () |
31 mainLoop :: StateT ServerState IO () |
32 mainLoop = forever $ do |
32 mainLoop = forever $ do |
33 si <- gets serverInfo |
33 si <- gets serverInfo |
34 r <- liftIO $ readChan $ coreChan si |
34 r <- liftIO $ readChan $ coreChan si |
35 |
35 |
36 case r of |
36 case r of |
62 return () |
62 return () |
63 --liftM snd $ |
63 --liftM snd $ |
64 -- foldM processAction (0, serverInfo, rnc) $ |
64 -- foldM processAction (0, serverInfo, rnc) $ |
65 -- PingAll : [StatsAction | even tick] |
65 -- PingAll : [StatsAction | even tick] |
66 |
66 |
|
67 FreeClient ci -> do |
|
68 rnc <- gets roomsClients |
|
69 liftIO $ removeClient rnc ci |
|
70 |
|
71 |
67 startServer :: ServerInfo -> Socket -> IO () |
72 startServer :: ServerInfo -> Socket -> IO () |
68 startServer serverInfo serverSocket = do |
73 startServer serverInfo serverSocket = do |
69 putStrLn $ "Listening on port " ++ show (listenPort serverInfo) |
74 putStrLn $ "Listening on port " ++ show (listenPort serverInfo) |
70 |
75 |
71 forkIO $ |
76 forkIO $ |
79 |
84 |
80 startDBConnection serverInfo |
85 startDBConnection serverInfo |
81 |
86 |
82 rnc <- newRoomsAndClients newRoom |
87 rnc <- newRoomsAndClients newRoom |
83 |
88 |
84 forkIO $ evalStateT mainLoop (ActionsState Nothing serverInfo rnc) |
89 forkIO $ evalStateT mainLoop (ServerState Nothing serverInfo rnc) |
85 |
90 |
86 forever $ threadDelay (60 * 60 * 10^6) >> putStrLn "***" |
91 forever $ threadDelay (60 * 60 * 10^6) >> putStrLn "***" |