21 |
21 |
22 firstAway (_, a, b, c) = (a, b, c) |
22 firstAway (_, a, b, c) = (a, b, c) |
23 |
23 |
24 reactCmd :: ServerInfo -> Int -> [String] -> Clients -> Rooms -> IO (ServerInfo, Clients, Rooms) |
24 reactCmd :: ServerInfo -> Int -> [String] -> Clients -> Rooms -> IO (ServerInfo, Clients, Rooms) |
25 reactCmd serverInfo clID cmd clients rooms = |
25 reactCmd serverInfo clID cmd clients rooms = |
26 liftM firstAway $ foldM processAction (clID, serverInfo, clients, rooms) $ handleCmd clID clients rooms cmd |
26 liftM firstAway $ foldM processAction (clID, serverInfo, clients, rooms) $ handleCmd clID clients rooms cmd |
27 |
27 |
28 mainLoop :: ServerInfo -> Clients -> Rooms -> IO () |
28 mainLoop :: ServerInfo -> Clients -> Rooms -> IO () |
29 mainLoop serverInfo clients rooms = do |
29 mainLoop serverInfo clients rooms = do |
30 r <- readChan $ coreChan serverInfo |
30 r <- readChan $ coreChan serverInfo |
31 |
31 |
32 (newServerInfo, mClients, mRooms) <- |
32 (newServerInfo, mClients, mRooms) <- |
33 case r of |
33 case r of |
34 Accept ci -> |
34 Accept ci -> |
35 liftM firstAway $ processAction |
35 liftM firstAway $ processAction |
36 (clientUID ci, serverInfo, clients, rooms) (AddClient ci) |
36 (clientUID ci, serverInfo, clients, rooms) (AddClient ci) |
37 |
37 |
38 ClientMessage (clID, cmd) -> do |
38 ClientMessage (clID, cmd) -> do |
39 debugM "Clients" $ (show clID) ++ ": " ++ (show cmd) |
39 debugM "Clients" $ (show clID) ++ ": " ++ (show cmd) |
40 if clID `IntMap.member` clients then |
40 if clID `IntMap.member` clients then |
41 reactCmd serverInfo clID cmd clients rooms |
41 reactCmd serverInfo clID cmd clients rooms |
42 else |
42 else |
43 do |
43 do |
44 debugM "Clients" "Message from dead client" |
44 debugM "Clients" "Message from dead client" |
45 return (serverInfo, clients, rooms) |
45 return (serverInfo, clients, rooms) |
46 |
46 |
47 ClientAccountInfo (clID, info) -> |
47 ClientAccountInfo (clID, info) -> |
48 if clID `IntMap.member` clients then |
48 if clID `IntMap.member` clients then |
49 liftM firstAway $ processAction |
49 liftM firstAway $ processAction |
50 (clID, serverInfo, clients, rooms) |
50 (clID, serverInfo, clients, rooms) |
51 (ProcessAccountInfo info) |
51 (ProcessAccountInfo info) |
52 else |
52 else |
53 do |
53 do |
54 debugM "Clients" "Got info for dead client" |
54 debugM "Clients" "Got info for dead client" |
55 return (serverInfo, clients, rooms) |
55 return (serverInfo, clients, rooms) |
56 |
56 |
57 TimerAction tick -> |
57 TimerAction tick -> |
58 liftM firstAway $ |
58 liftM firstAway $ |
59 foldM processAction (0, serverInfo, clients, rooms) $ |
59 foldM processAction (0, serverInfo, clients, rooms) $ |
60 PingAll : [StatsAction | even tick] |
60 PingAll : [StatsAction | even tick] |
61 |
61 |
62 |
62 |
63 {- let hadRooms = (not $ null rooms) && (null mrooms) |
63 {- let hadRooms = (not $ null rooms) && (null mrooms) |
64 in unless ((not $ isDedicated serverInfo) && ((null clientsIn) || hadRooms)) $ |
64 in unless ((not $ isDedicated serverInfo) && ((null clientsIn) || hadRooms)) $ |
65 mainLoop serverInfo acceptChan messagesChan clientsIn mrooms -} |
65 mainLoop serverInfo acceptChan messagesChan clientsIn mrooms -} |
66 |
66 |
67 mainLoop newServerInfo mClients mRooms |
67 mainLoop newServerInfo mClients mRooms |
68 |
68 |
69 startServer :: ServerInfo -> Socket -> IO () |
69 startServer :: ServerInfo -> Socket -> IO () |
70 startServer serverInfo serverSocket = do |
70 startServer serverInfo serverSocket = do |
71 putStrLn $ "Listening on port " ++ show (listenPort serverInfo) |
71 putStrLn $ "Listening on port " ++ show (listenPort serverInfo) |
72 |
72 |
73 forkIO $ |
73 forkIO $ |
74 acceptLoop |
74 acceptLoop |
75 serverSocket |
75 serverSocket |
76 (coreChan serverInfo) |
76 (coreChan serverInfo) |
77 0 |
77 0 |
78 |
78 |
79 return () |
79 return () |
80 |
80 |
81 forkIO $ timerLoop 0 $ coreChan serverInfo |
81 forkIO $ timerLoop 0 $ coreChan serverInfo |
82 |
82 |
83 startDBConnection serverInfo |
83 startDBConnection serverInfo |
84 |
84 |
85 forkIO $ mainLoop serverInfo IntMap.empty (IntMap.singleton 0 newRoom) |
85 forkIO $ mainLoop serverInfo IntMap.empty (IntMap.singleton 0 newRoom) |
86 |
86 |
87 forever $ threadDelay (60 * 60 * 10^6) >> putStrLn "***" |
87 forever $ threadDelay (60 * 60 * 10^6) >> putStrLn "***" |