|
1 module ServerCore where |
|
2 |
|
3 import Network |
|
4 import Control.Concurrent |
|
5 import Control.Concurrent.STM |
|
6 import Control.Concurrent.Chan |
|
7 import Control.Monad |
|
8 import qualified Data.IntMap as IntMap |
|
9 import System.Log.Logger |
|
10 -------------------------------------- |
|
11 import CoreTypes |
|
12 import NetRoutines |
|
13 import Utils |
|
14 import HWProtoCore |
|
15 import Actions |
|
16 |
|
17 reactCmd :: ServerInfo -> Int -> [String] -> Clients -> Rooms -> IO (ServerInfo, Clients, Rooms) |
|
18 reactCmd serverInfo clID cmd clients rooms = do |
|
19 (_ , serverInfo, clients, rooms) <- |
|
20 foldM processAction (clID, serverInfo, clients, rooms) $ handleCmd clID clients rooms cmd |
|
21 return (serverInfo, clients, rooms) |
|
22 |
|
23 mainLoop :: Chan CoreMessage -> ServerInfo -> Clients -> Rooms -> IO () |
|
24 mainLoop coreChan serverInfo clients rooms = do |
|
25 r <- readChan coreChan |
|
26 |
|
27 (newServerInfo, mClients, mRooms) <- |
|
28 case r of |
|
29 Accept ci -> do |
|
30 let updatedClients = IntMap.insert (clientUID ci) ci clients |
|
31 --infoM "Clients" ("New client: id " ++ (show $ clientUID ci)) |
|
32 processAction |
|
33 (clientUID ci, serverInfo, updatedClients, rooms) |
|
34 (AnswerThisClient ["CONNECTED", "Hedgewars server http://www.hedgewars.org/"]) |
|
35 return (serverInfo, updatedClients, rooms) |
|
36 |
|
37 ClientMessage (clID, cmd) -> do |
|
38 debugM "Clients" $ (show clID) ++ ": " ++ (show cmd) |
|
39 if clID `IntMap.member` clients then |
|
40 reactCmd serverInfo clID cmd clients rooms |
|
41 else |
|
42 do |
|
43 debugM "Clients" "Message from dead client" |
|
44 return (serverInfo, clients, rooms) |
|
45 |
|
46 {- let hadRooms = (not $ null rooms) && (null mrooms) |
|
47 in unless ((not $ isDedicated serverInfo) && ((null clientsIn) || hadRooms)) $ |
|
48 mainLoop serverInfo acceptChan messagesChan clientsIn mrooms -} |
|
49 |
|
50 mainLoop coreChan newServerInfo mClients mRooms |
|
51 |
|
52 startServer :: ServerInfo -> Chan CoreMessage -> Socket -> IO () |
|
53 startServer serverInfo coreChan serverSocket = do |
|
54 putStrLn $ "Listening on port " ++ show (listenPort serverInfo) |
|
55 |
|
56 forkIO $ |
|
57 acceptLoop |
|
58 serverSocket |
|
59 coreChan |
|
60 0 |
|
61 |
|
62 return () |
|
63 |
|
64 {- forkIO $ messagesLoop messagesChan |
|
65 forkIO $ timerLoop messagesChan-} |
|
66 |
|
67 -- startDBConnection $ dbQueries serverInfo |
|
68 |
|
69 mainLoop coreChan serverInfo IntMap.empty (IntMap.singleton 0 newRoom) |
|
70 |
|
71 |
|
72 |