|
1 module Actions where |
|
2 |
|
3 import Control.Concurrent.STM |
|
4 import Control.Concurrent.Chan |
|
5 import Data.IntMap |
|
6 import qualified Data.IntSet as IntSet |
|
7 import Monad |
|
8 ----------------------------- |
|
9 import CoreTypes |
|
10 |
|
11 data Action = |
|
12 AnswerThisClient [String] |
|
13 | AnswerAll [String] |
|
14 | AnswerAllOthers [String] |
|
15 | AnswerThisRoom [String] |
|
16 | AnswerOthersInRoom [String] |
|
17 | AnswerLobby [String] |
|
18 | RoomAddThisClient Int -- roomID |
|
19 | RoomRemoveThisClient |
|
20 | RemoveRoom |
|
21 | ProtocolError String |
|
22 | Warning String |
|
23 | ByeClient String |
|
24 | ModifyClient (ClientInfo -> ClientInfo) |
|
25 | ModifyRoom (RoomInfo -> RoomInfo) |
|
26 | AddRoom String String |
|
27 | Dump |
|
28 |
|
29 type CmdHandler = Int -> Clients -> Rooms -> [String] -> [Action] |
|
30 |
|
31 |
|
32 processAction :: (Int, ServerInfo, Clients, Rooms) -> Action -> IO (Int, ServerInfo, Clients, Rooms) |
|
33 |
|
34 |
|
35 processAction (clID, serverInfo, clients, rooms) (AnswerThisClient msg) = do |
|
36 writeChan (sendChan $ clients ! clID) msg |
|
37 return (clID, serverInfo, clients, rooms) |
|
38 |
|
39 |
|
40 processAction (clID, serverInfo, clients, rooms) (AnswerAll msg) = do |
|
41 mapM_ (\id -> writeChan (sendChan $ clients ! id) msg) (keys clients) |
|
42 return (clID, serverInfo, clients, rooms) |
|
43 |
|
44 |
|
45 processAction (clID, serverInfo, clients, rooms) (AnswerAllOthers msg) = do |
|
46 mapM_ (\id -> writeChan (sendChan $ clients ! id) msg) $ Prelude.filter (/= clID) (keys clients) |
|
47 return (clID, serverInfo, clients, rooms) |
|
48 |
|
49 |
|
50 processAction (clID, serverInfo, clients, rooms) (AnswerThisRoom msg) = do |
|
51 mapM_ (\id -> writeChan (sendChan $ clients ! id) msg) roomClients |
|
52 return (clID, serverInfo, clients, rooms) |
|
53 where |
|
54 roomClients = IntSet.elems $ playersIDs room |
|
55 room = rooms ! rID |
|
56 rID = roomID client |
|
57 client = clients ! clID |
|
58 |
|
59 |
|
60 processAction (clID, serverInfo, clients, rooms) (AnswerOthersInRoom msg) = do |
|
61 mapM_ (\id -> writeChan (sendChan $ clients ! id) msg) $ Prelude.filter (/= clID) roomClients |
|
62 return (clID, serverInfo, clients, rooms) |
|
63 where |
|
64 roomClients = IntSet.elems $ playersIDs room |
|
65 room = rooms ! rID |
|
66 rID = roomID client |
|
67 client = clients ! clID |
|
68 |
|
69 |
|
70 processAction (clID, serverInfo, clients, rooms) (AnswerLobby msg) = do |
|
71 mapM_ (\id -> writeChan (sendChan $ clients ! id) msg) roomClients |
|
72 return (clID, serverInfo, clients, rooms) |
|
73 where |
|
74 roomClients = IntSet.elems $ playersIDs room |
|
75 room = rooms ! 0 |
|
76 |
|
77 |
|
78 processAction (clID, serverInfo, clients, rooms) (ProtocolError msg) = do |
|
79 writeChan (sendChan $ clients ! clID) ["ERROR", msg] |
|
80 return (clID, serverInfo, clients, rooms) |
|
81 |
|
82 |
|
83 processAction (clID, serverInfo, clients, rooms) (Warning msg) = do |
|
84 writeChan (sendChan $ clients ! clID) ["WARNING", msg] |
|
85 return (clID, serverInfo, clients, rooms) |
|
86 |
|
87 |
|
88 processAction (clID, serverInfo, clients, rooms) (ByeClient msg) = do |
|
89 mapM_ (processAction (clID, serverInfo, clients, rooms)) $ answerOthersQuit ++ answerInformRoom |
|
90 writeChan (sendChan $ clients ! clID) ["BYE"] |
|
91 return ( |
|
92 0, |
|
93 serverInfo, |
|
94 delete clID clients, |
|
95 adjust (\r -> r{playersIDs = IntSet.delete clID (playersIDs r), playersIn = (playersIn r) - 1}) rID rooms |
|
96 ) |
|
97 where |
|
98 client = clients ! clID |
|
99 rID = roomID client |
|
100 clientNick = nick client |
|
101 answerInformRoom = |
|
102 if roomID client /= 0 then |
|
103 if not $ Prelude.null msg then |
|
104 [AnswerThisRoom ["LEFT", clientNick, msg]] |
|
105 else |
|
106 [AnswerThisRoom ["LEFT", clientNick]] |
|
107 else |
|
108 [] |
|
109 answerOthersQuit = |
|
110 if not $ Prelude.null clientNick then |
|
111 if not $ Prelude.null msg then |
|
112 [AnswerAll ["LOBBY:LEFT", clientNick, msg]] |
|
113 else |
|
114 [AnswerAll ["LOBBY:LEFT", clientNick]] |
|
115 else |
|
116 [] |
|
117 |
|
118 |
|
119 processAction (clID, serverInfo, clients, rooms) (ModifyClient func) = do |
|
120 return (clID, serverInfo, adjust func clID clients, rooms) |
|
121 |
|
122 |
|
123 processAction (clID, serverInfo, clients, rooms) (ModifyRoom func) = do |
|
124 return (clID, serverInfo, clients, adjust func rID rooms) |
|
125 where |
|
126 rID = roomID $ clients ! clID |
|
127 |
|
128 |
|
129 processAction (clID, serverInfo, clients, rooms) (RoomAddThisClient rID) = do |
|
130 processAction ( |
|
131 clID, |
|
132 serverInfo, |
|
133 adjust (\cl -> cl{roomID = rID}) clID clients, |
|
134 adjust (\r -> r{playersIDs = IntSet.insert clID (playersIDs r), playersIn = (playersIn r) + 1}) rID $ |
|
135 adjust (\r -> r{playersIDs = IntSet.delete clID (playersIDs r)}) 0 rooms |
|
136 ) joinMsg |
|
137 where |
|
138 client = clients ! clID |
|
139 joinMsg = if rID == 0 then |
|
140 AnswerAllOthers ["LOBBY:JOINED", nick client] |
|
141 else |
|
142 AnswerThisRoom ["JOINED", nick client] |
|
143 |
|
144 |
|
145 processAction (clID, serverInfo, clients, rooms) (RoomRemoveThisClient) = do |
|
146 when (rID /= 0) $ (processAction (clID, serverInfo, clients, rooms) $ AnswerOthersInRoom ["LEFT", nick client, "part"]) >> return () |
|
147 return ( |
|
148 clID, |
|
149 serverInfo, |
|
150 adjust (\cl -> cl{roomID = 0}) clID clients, |
|
151 adjust (\r -> r{playersIDs = IntSet.delete clID (playersIDs r), playersIn = (playersIn r) - 1}) rID $ |
|
152 adjust (\r -> r{playersIDs = IntSet.insert clID (playersIDs r)}) 0 rooms |
|
153 ) |
|
154 where |
|
155 rID = roomID client |
|
156 client = clients ! clID |
|
157 |
|
158 |
|
159 processAction (clID, serverInfo, clients, rooms) (AddRoom roomName roomPassword) = do |
|
160 let newServerInfo = serverInfo {nextRoomID = newID} |
|
161 let room = newRoom{ |
|
162 roomUID = newID, |
|
163 name = roomName, |
|
164 password = roomPassword, |
|
165 roomProto = (clientProto client) |
|
166 } |
|
167 |
|
168 processAction (clID, serverInfo, clients, rooms) $ AnswerLobby ["ROOM", "ADD", roomName] |
|
169 |
|
170 processAction ( |
|
171 clID, |
|
172 newServerInfo, |
|
173 adjust (\cl -> cl{isMaster = True}) clID clients, |
|
174 insert newID room rooms |
|
175 ) $ RoomAddThisClient newID |
|
176 where |
|
177 newID = (nextRoomID serverInfo) - 1 |
|
178 client = clients ! clID |
|
179 |
|
180 |
|
181 processAction (clID, serverInfo, clients, rooms) (RemoveRoom) = do |
|
182 processAction (clID, serverInfo, clients, rooms) $ AnswerLobby ["ROOM", "DEL", name clRoom] |
|
183 processAction (clID, serverInfo, clients, rooms) $ AnswerOthersInRoom ["ROOMABANDONED", name clRoom] |
|
184 return (clID, |
|
185 serverInfo, |
|
186 Data.IntMap.map (\cl -> if roomID cl == rID then cl{roomID = 0, isMaster = False} else cl) clients, |
|
187 delete rID $ adjust (\r -> r{playersIDs = IntSet.union (playersIDs clRoom) (playersIDs r)}) 0 rooms |
|
188 ) |
|
189 where |
|
190 clRoom = rooms ! rID |
|
191 rID = roomID client |
|
192 client = clients ! clID |
|
193 |
|
194 processAction (clID, serverInfo, clients, rooms) (Dump) = do |
|
195 writeChan (sendChan $ clients ! clID) ["DUMP", show serverInfo, showTree clients, showTree rooms] |
|
196 return (clID, serverInfo, clients, rooms) |
|
197 |