| author | unc0rr |
| Thu, 11 Nov 2010 22:17:54 +0300 | |
| branch | 0.9.14 |
| changeset 4242 | 5e3c5fe2cb14 |
| parent 3947 | 709fdb89f76c |
| child 4295 | 1f5604cd99be |
| permissions | -rw-r--r-- |
| 1804 | 1 |
module ServerCore where |
2 |
||
3 |
import Network |
|
4 |
import Control.Concurrent |
|
| 4242 | 5 |
import Control.Concurrent.STM |
| 1804 | 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 |
|
| 4242 | 13 |
import Utils |
| 1804 | 14 |
import HWProtoCore |
15 |
import Actions |
|
| 1833 | 16 |
import OfficialServer.DBInteraction |
|
1927
e2031906a347
Ping clients every 30 seconds. Disconnection due to ping timeout to be implemented.
unc0rr
parents:
1926
diff
changeset
|
17 |
|
|
1839
5dd4cb7fd7e5
Server now send ASKPASSWORD command to frontend when user has web account
unc0rr
parents:
1833
diff
changeset
|
18 |
|
| 4242 | 19 |
timerLoop :: Int -> Chan CoreMessage -> IO() |
20 |
timerLoop tick messagesChan = threadDelay (30 * 10^6) >> writeChan messagesChan (TimerAction tick) >> timerLoop (tick + 1) messagesChan |
|
21 |
||
22 |
firstAway (_, a, b, c) = (a, b, c) |
|
23 |
||
24 |
reactCmd :: ServerInfo -> Int -> [String] -> Clients -> Rooms -> IO (ServerInfo, Clients, Rooms) |
|
25 |
reactCmd serverInfo clID cmd clients rooms = |
|
26 |
liftM firstAway $ foldM processAction (clID, serverInfo, clients, rooms) $ handleCmd clID clients rooms cmd |
|
| 1804 | 27 |
|
| 4242 | 28 |
mainLoop :: ServerInfo -> Clients -> Rooms -> IO () |
29 |
mainLoop serverInfo clients rooms = do |
|
30 |
r <- readChan $ coreChan serverInfo |
|
31 |
||
32 |
(newServerInfo, mClients, mRooms) <- |
|
33 |
case r of |
|
34 |
Accept ci -> |
|
35 |
liftM firstAway $ processAction |
|
36 |
(clientUID ci, serverInfo, clients, rooms) (AddClient ci) |
|
| 3566 | 37 |
|
| 4242 | 38 |
ClientMessage (clID, cmd) -> do |
39 |
debugM "Clients" $ (show clID) ++ ": " ++ (show cmd) |
|
40 |
if clID `IntMap.member` clients then |
|
41 |
reactCmd serverInfo clID cmd clients rooms |
|
42 |
else |
|
43 |
do |
|
44 |
debugM "Clients" "Message from dead client" |
|
45 |
return (serverInfo, clients, rooms) |
|
| 3566 | 46 |
|
| 4242 | 47 |
ClientAccountInfo (clID, info) -> |
48 |
if clID `IntMap.member` clients then |
|
49 |
liftM firstAway $ processAction |
|
50 |
(clID, serverInfo, clients, rooms) |
|
51 |
(ProcessAccountInfo info) |
|
52 |
else |
|
53 |
do |
|
54 |
debugM "Clients" "Got info for dead client" |
|
55 |
return (serverInfo, clients, rooms) |
|
| 1804 | 56 |
|
| 4242 | 57 |
TimerAction tick -> |
58 |
liftM firstAway $ |
|
59 |
foldM processAction (0, serverInfo, clients, rooms) $ |
|
60 |
PingAll : [StatsAction | even tick] |
|
61 |
||
|
3741
73246d25dfe1
Add some more strictness, use unsafeThaw and unsafeFreeze functions which work at O(1)
unc0rr
parents:
3673
diff
changeset
|
62 |
|
| 4242 | 63 |
{- let hadRooms = (not $ null rooms) && (null mrooms)
|
64 |
in unless ((not $ isDedicated serverInfo) && ((null clientsIn) || hadRooms)) $ |
|
65 |
mainLoop serverInfo acceptChan messagesChan clientsIn mrooms -} |
|
| 1804 | 66 |
|
| 4242 | 67 |
mainLoop newServerInfo mClients mRooms |
| 3458 | 68 |
|
|
1927
e2031906a347
Ping clients every 30 seconds. Disconnection due to ping timeout to be implemented.
unc0rr
parents:
1926
diff
changeset
|
69 |
startServer :: ServerInfo -> Socket -> IO () |
|
e2031906a347
Ping clients every 30 seconds. Disconnection due to ping timeout to be implemented.
unc0rr
parents:
1926
diff
changeset
|
70 |
startServer serverInfo serverSocket = do |
|
2867
9be6693c78cb
- Unbreak support for client versions prior to 0.9.13-dev
unc0rr
parents:
2349
diff
changeset
|
71 |
putStrLn $ "Listening on port " ++ show (listenPort serverInfo) |
| 1804 | 72 |
|
|
2867
9be6693c78cb
- Unbreak support for client versions prior to 0.9.13-dev
unc0rr
parents:
2349
diff
changeset
|
73 |
forkIO $ |
|
9be6693c78cb
- Unbreak support for client versions prior to 0.9.13-dev
unc0rr
parents:
2349
diff
changeset
|
74 |
acceptLoop |
|
9be6693c78cb
- Unbreak support for client versions prior to 0.9.13-dev
unc0rr
parents:
2349
diff
changeset
|
75 |
serverSocket |
|
9be6693c78cb
- Unbreak support for client versions prior to 0.9.13-dev
unc0rr
parents:
2349
diff
changeset
|
76 |
(coreChan serverInfo) |
| 4242 | 77 |
0 |
| 1804 | 78 |
|
|
2867
9be6693c78cb
- Unbreak support for client versions prior to 0.9.13-dev
unc0rr
parents:
2349
diff
changeset
|
79 |
return () |
| 4242 | 80 |
|
81 |
forkIO $ timerLoop 0 $ coreChan serverInfo |
|
| 1804 | 82 |
|
|
2867
9be6693c78cb
- Unbreak support for client versions prior to 0.9.13-dev
unc0rr
parents:
2349
diff
changeset
|
83 |
startDBConnection serverInfo |
| 1804 | 84 |
|
| 4242 | 85 |
forkIO $ mainLoop serverInfo IntMap.empty (IntMap.singleton 0 newRoom) |
| 3435 | 86 |
|
| 4242 | 87 |
forever $ threadDelay (60 * 60 * 10^6) >> putStrLn "***" |