author | unc0rr |
Fri, 27 Mar 2009 20:29:38 +0000 | |
changeset 1927 | e2031906a347 |
parent 1926 | cb46fbdcaa41 |
child 2116 | dec7ead2d178 |
permissions | -rw-r--r-- |
1804 | 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 |
|
1833 | 16 |
import OfficialServer.DBInteraction |
1804 | 17 |
|
1839
5dd4cb7fd7e5
Server now send ASKPASSWORD command to frontend when user has web account
unc0rr
parents:
1833
diff
changeset
|
18 |
|
1927
e2031906a347
Ping clients every 30 seconds. Disconnection due to ping timeout to be implemented.
unc0rr
parents:
1926
diff
changeset
|
19 |
timerLoop :: Chan CoreMessage -> IO() |
e2031906a347
Ping clients every 30 seconds. Disconnection due to ping timeout to be implemented.
unc0rr
parents:
1926
diff
changeset
|
20 |
timerLoop messagesChan = forever $ do |
e2031906a347
Ping clients every 30 seconds. Disconnection due to ping timeout to be implemented.
unc0rr
parents:
1926
diff
changeset
|
21 |
threadDelay (30 * 10^6) -- 30 seconds |
e2031906a347
Ping clients every 30 seconds. Disconnection due to ping timeout to be implemented.
unc0rr
parents:
1926
diff
changeset
|
22 |
writeChan messagesChan TimerAction |
e2031906a347
Ping clients every 30 seconds. Disconnection due to ping timeout to be implemented.
unc0rr
parents:
1926
diff
changeset
|
23 |
|
1839
5dd4cb7fd7e5
Server now send ASKPASSWORD command to frontend when user has web account
unc0rr
parents:
1833
diff
changeset
|
24 |
firstAway (_, a, b, c) = (a, b, c) |
5dd4cb7fd7e5
Server now send ASKPASSWORD command to frontend when user has web account
unc0rr
parents:
1833
diff
changeset
|
25 |
|
1804 | 26 |
reactCmd :: ServerInfo -> Int -> [String] -> Clients -> Rooms -> IO (ServerInfo, Clients, Rooms) |
1841
fba7210b438b
Retrieve client password from web database and ask for it
unc0rr
parents:
1839
diff
changeset
|
27 |
reactCmd serverInfo clID cmd clients rooms = |
fba7210b438b
Retrieve client password from web database and ask for it
unc0rr
parents:
1839
diff
changeset
|
28 |
liftM firstAway $ foldM processAction (clID, serverInfo, clients, rooms) $ handleCmd clID clients rooms cmd |
1804 | 29 |
|
1839
5dd4cb7fd7e5
Server now send ASKPASSWORD command to frontend when user has web account
unc0rr
parents:
1833
diff
changeset
|
30 |
mainLoop :: ServerInfo -> Clients -> Rooms -> IO () |
5dd4cb7fd7e5
Server now send ASKPASSWORD command to frontend when user has web account
unc0rr
parents:
1833
diff
changeset
|
31 |
mainLoop serverInfo clients rooms = do |
5dd4cb7fd7e5
Server now send ASKPASSWORD command to frontend when user has web account
unc0rr
parents:
1833
diff
changeset
|
32 |
r <- readChan $ coreChan serverInfo |
1804 | 33 |
|
34 |
(newServerInfo, mClients, mRooms) <- |
|
35 |
case r of |
|
36 |
Accept ci -> do |
|
1841
fba7210b438b
Retrieve client password from web database and ask for it
unc0rr
parents:
1839
diff
changeset
|
37 |
liftM firstAway $ processAction |
1926
cb46fbdcaa41
Add simple DoS protection mechanism (although better than previous server had)
unc0rr
parents:
1841
diff
changeset
|
38 |
(clientUID ci, serverInfo, clients, rooms) (AddClient ci) |
1804 | 39 |
|
40 |
ClientMessage (clID, cmd) -> do |
|
41 |
debugM "Clients" $ (show clID) ++ ": " ++ (show cmd) |
|
42 |
if clID `IntMap.member` clients then |
|
43 |
reactCmd serverInfo clID cmd clients rooms |
|
44 |
else |
|
45 |
do |
|
46 |
debugM "Clients" "Message from dead client" |
|
47 |
return (serverInfo, clients, rooms) |
|
48 |
||
1839
5dd4cb7fd7e5
Server now send ASKPASSWORD command to frontend when user has web account
unc0rr
parents:
1833
diff
changeset
|
49 |
ClientAccountInfo clID info -> |
5dd4cb7fd7e5
Server now send ASKPASSWORD command to frontend when user has web account
unc0rr
parents:
1833
diff
changeset
|
50 |
if clID `IntMap.member` clients then |
5dd4cb7fd7e5
Server now send ASKPASSWORD command to frontend when user has web account
unc0rr
parents:
1833
diff
changeset
|
51 |
liftM firstAway $ processAction |
5dd4cb7fd7e5
Server now send ASKPASSWORD command to frontend when user has web account
unc0rr
parents:
1833
diff
changeset
|
52 |
(clID, serverInfo, clients, rooms) |
5dd4cb7fd7e5
Server now send ASKPASSWORD command to frontend when user has web account
unc0rr
parents:
1833
diff
changeset
|
53 |
(ProcessAccountInfo info) |
5dd4cb7fd7e5
Server now send ASKPASSWORD command to frontend when user has web account
unc0rr
parents:
1833
diff
changeset
|
54 |
else |
5dd4cb7fd7e5
Server now send ASKPASSWORD command to frontend when user has web account
unc0rr
parents:
1833
diff
changeset
|
55 |
do |
5dd4cb7fd7e5
Server now send ASKPASSWORD command to frontend when user has web account
unc0rr
parents:
1833
diff
changeset
|
56 |
debugM "Clients" "Got info for dead client" |
5dd4cb7fd7e5
Server now send ASKPASSWORD command to frontend when user has web account
unc0rr
parents:
1833
diff
changeset
|
57 |
return (serverInfo, clients, rooms) |
1927
e2031906a347
Ping clients every 30 seconds. Disconnection due to ping timeout to be implemented.
unc0rr
parents:
1926
diff
changeset
|
58 |
|
e2031906a347
Ping clients every 30 seconds. Disconnection due to ping timeout to be implemented.
unc0rr
parents:
1926
diff
changeset
|
59 |
TimerAction -> |
e2031906a347
Ping clients every 30 seconds. Disconnection due to ping timeout to be implemented.
unc0rr
parents:
1926
diff
changeset
|
60 |
liftM firstAway $ processAction |
e2031906a347
Ping clients every 30 seconds. Disconnection due to ping timeout to be implemented.
unc0rr
parents:
1926
diff
changeset
|
61 |
(0, serverInfo, clients, rooms) |
e2031906a347
Ping clients every 30 seconds. Disconnection due to ping timeout to be implemented.
unc0rr
parents:
1926
diff
changeset
|
62 |
PingAll |
1839
5dd4cb7fd7e5
Server now send ASKPASSWORD command to frontend when user has web account
unc0rr
parents:
1833
diff
changeset
|
63 |
|
5dd4cb7fd7e5
Server now send ASKPASSWORD command to frontend when user has web account
unc0rr
parents:
1833
diff
changeset
|
64 |
|
1804 | 65 |
{- let hadRooms = (not $ null rooms) && (null mrooms) |
66 |
in unless ((not $ isDedicated serverInfo) && ((null clientsIn) || hadRooms)) $ |
|
67 |
mainLoop serverInfo acceptChan messagesChan clientsIn mrooms -} |
|
68 |
||
1839
5dd4cb7fd7e5
Server now send ASKPASSWORD command to frontend when user has web account
unc0rr
parents:
1833
diff
changeset
|
69 |
mainLoop newServerInfo mClients mRooms |
1804 | 70 |
|
1927
e2031906a347
Ping clients every 30 seconds. Disconnection due to ping timeout to be implemented.
unc0rr
parents:
1926
diff
changeset
|
71 |
startServer :: ServerInfo -> Socket -> IO () |
e2031906a347
Ping clients every 30 seconds. Disconnection due to ping timeout to be implemented.
unc0rr
parents:
1926
diff
changeset
|
72 |
startServer serverInfo serverSocket = do |
1804 | 73 |
putStrLn $ "Listening on port " ++ show (listenPort serverInfo) |
74 |
||
75 |
forkIO $ |
|
76 |
acceptLoop |
|
77 |
serverSocket |
|
1927
e2031906a347
Ping clients every 30 seconds. Disconnection due to ping timeout to be implemented.
unc0rr
parents:
1926
diff
changeset
|
78 |
(coreChan serverInfo) |
1804 | 79 |
0 |
80 |
||
81 |
return () |
|
82 |
||
1927
e2031906a347
Ping clients every 30 seconds. Disconnection due to ping timeout to be implemented.
unc0rr
parents:
1926
diff
changeset
|
83 |
forkIO $ timerLoop $ coreChan serverInfo |
1804 | 84 |
|
1833 | 85 |
startDBConnection $ serverInfo |
1804 | 86 |
|
1839
5dd4cb7fd7e5
Server now send ASKPASSWORD command to frontend when user has web account
unc0rr
parents:
1833
diff
changeset
|
87 |
mainLoop serverInfo IntMap.empty (IntMap.singleton 0 newRoom) |