13 import Utils |
13 import Utils |
14 import HWProtoCore |
14 import HWProtoCore |
15 import Actions |
15 import Actions |
16 import OfficialServer.DBInteraction |
16 import OfficialServer.DBInteraction |
17 |
17 |
|
18 |
|
19 firstAway (_, a, b, c) = (a, b, c) |
|
20 |
18 reactCmd :: ServerInfo -> Int -> [String] -> Clients -> Rooms -> IO (ServerInfo, Clients, Rooms) |
21 reactCmd :: ServerInfo -> Int -> [String] -> Clients -> Rooms -> IO (ServerInfo, Clients, Rooms) |
19 reactCmd serverInfo clID cmd clients rooms = do |
22 reactCmd serverInfo clID cmd clients rooms = do |
20 (_ , serverInfo, clients, rooms) <- |
23 (_ , serverInfo, clients, rooms) <- |
21 foldM processAction (clID, serverInfo, clients, rooms) $ handleCmd clID clients rooms cmd |
24 foldM processAction (clID, serverInfo, clients, rooms) $ handleCmd clID clients rooms cmd |
22 return (serverInfo, clients, rooms) |
25 return (serverInfo, clients, rooms) |
23 |
26 |
24 mainLoop :: Chan CoreMessage -> ServerInfo -> Clients -> Rooms -> IO () |
27 mainLoop :: ServerInfo -> Clients -> Rooms -> IO () |
25 mainLoop coreChan serverInfo clients rooms = do |
28 mainLoop serverInfo clients rooms = do |
26 r <- readChan coreChan |
29 r <- readChan $ coreChan serverInfo |
27 |
30 |
28 (newServerInfo, mClients, mRooms) <- |
31 (newServerInfo, mClients, mRooms) <- |
29 case r of |
32 case r of |
30 Accept ci -> do |
33 Accept ci -> do |
31 let updatedClients = IntMap.insert (clientUID ci) ci clients |
34 let updatedClients = IntMap.insert (clientUID ci) ci clients |
32 --infoM "Clients" ("New client: id " ++ (show $ clientUID ci)) |
35 infoM "Clients" ("New client: id " ++ (show $ clientUID ci)) |
33 processAction |
36 processAction |
34 (clientUID ci, serverInfo, updatedClients, rooms) |
37 (clientUID ci, serverInfo, updatedClients, rooms) |
35 (AnswerThisClient ["CONNECTED", "Hedgewars server http://www.hedgewars.org/"]) |
38 (AnswerThisClient ["CONNECTED", "Hedgewars server http://www.hedgewars.org/"]) |
36 return (serverInfo, updatedClients, rooms) |
39 return (serverInfo, updatedClients, rooms) |
37 |
40 |
42 else |
45 else |
43 do |
46 do |
44 debugM "Clients" "Message from dead client" |
47 debugM "Clients" "Message from dead client" |
45 return (serverInfo, clients, rooms) |
48 return (serverInfo, clients, rooms) |
46 |
49 |
|
50 ClientAccountInfo clID info -> |
|
51 if clID `IntMap.member` clients then |
|
52 liftM firstAway $ processAction |
|
53 (clID, serverInfo, clients, rooms) |
|
54 (ProcessAccountInfo info) |
|
55 else |
|
56 do |
|
57 debugM "Clients" "Got info for dead client" |
|
58 return (serverInfo, clients, rooms) |
|
59 |
|
60 |
47 {- let hadRooms = (not $ null rooms) && (null mrooms) |
61 {- let hadRooms = (not $ null rooms) && (null mrooms) |
48 in unless ((not $ isDedicated serverInfo) && ((null clientsIn) || hadRooms)) $ |
62 in unless ((not $ isDedicated serverInfo) && ((null clientsIn) || hadRooms)) $ |
49 mainLoop serverInfo acceptChan messagesChan clientsIn mrooms -} |
63 mainLoop serverInfo acceptChan messagesChan clientsIn mrooms -} |
50 |
64 |
51 mainLoop coreChan newServerInfo mClients mRooms |
65 mainLoop newServerInfo mClients mRooms |
52 |
66 |
53 startServer :: ServerInfo -> Chan CoreMessage -> Socket -> IO () |
67 startServer :: ServerInfo -> Chan CoreMessage -> Socket -> IO () |
54 startServer serverInfo coreChan serverSocket = do |
68 startServer serverInfo coreChan serverSocket = do |
55 putStrLn $ "Listening on port " ++ show (listenPort serverInfo) |
69 putStrLn $ "Listening on port " ++ show (listenPort serverInfo) |
56 |
70 |