author | Wuzzy <almikes@aol.com> |
Wed, 23 Nov 2016 20:25:44 +0100 | |
changeset 12053 | 475a1289f940 |
parent 11471 | 4b5c7a5c49fd |
permissions | -rw-r--r-- |
10460
8dcea9087d75
Added copyrights to gameServer directory
Gianfranco Costamagna <costamagnagianfranco@yahoo.it>
parents:
10215
diff
changeset
|
1 |
{- |
8dcea9087d75
Added copyrights to gameServer directory
Gianfranco Costamagna <costamagnagianfranco@yahoo.it>
parents:
10215
diff
changeset
|
2 |
* Hedgewars, a free turn based strategy game |
11046 | 3 |
* Copyright (c) 2004-2015 Andrey Korotaev <unC0Rr@gmail.com> |
10460
8dcea9087d75
Added copyrights to gameServer directory
Gianfranco Costamagna <costamagnagianfranco@yahoo.it>
parents:
10215
diff
changeset
|
4 |
* |
8dcea9087d75
Added copyrights to gameServer directory
Gianfranco Costamagna <costamagnagianfranco@yahoo.it>
parents:
10215
diff
changeset
|
5 |
* This program is free software; you can redistribute it and/or modify |
8dcea9087d75
Added copyrights to gameServer directory
Gianfranco Costamagna <costamagnagianfranco@yahoo.it>
parents:
10215
diff
changeset
|
6 |
* it under the terms of the GNU General Public License as published by |
8dcea9087d75
Added copyrights to gameServer directory
Gianfranco Costamagna <costamagnagianfranco@yahoo.it>
parents:
10215
diff
changeset
|
7 |
* the Free Software Foundation; version 2 of the License |
8dcea9087d75
Added copyrights to gameServer directory
Gianfranco Costamagna <costamagnagianfranco@yahoo.it>
parents:
10215
diff
changeset
|
8 |
* |
8dcea9087d75
Added copyrights to gameServer directory
Gianfranco Costamagna <costamagnagianfranco@yahoo.it>
parents:
10215
diff
changeset
|
9 |
* This program is distributed in the hope that it will be useful, |
8dcea9087d75
Added copyrights to gameServer directory
Gianfranco Costamagna <costamagnagianfranco@yahoo.it>
parents:
10215
diff
changeset
|
10 |
* but WITHOUT ANY WARRANTY; without even the implied warranty of |
8dcea9087d75
Added copyrights to gameServer directory
Gianfranco Costamagna <costamagnagianfranco@yahoo.it>
parents:
10215
diff
changeset
|
11 |
* MERCHANTABILITY or FITNESS FOR A PARTICULAR PURPOSE. See the |
8dcea9087d75
Added copyrights to gameServer directory
Gianfranco Costamagna <costamagnagianfranco@yahoo.it>
parents:
10215
diff
changeset
|
12 |
* GNU General Public License for more details. |
8dcea9087d75
Added copyrights to gameServer directory
Gianfranco Costamagna <costamagnagianfranco@yahoo.it>
parents:
10215
diff
changeset
|
13 |
* |
8dcea9087d75
Added copyrights to gameServer directory
Gianfranco Costamagna <costamagnagianfranco@yahoo.it>
parents:
10215
diff
changeset
|
14 |
* You should have received a copy of the GNU General Public License |
8dcea9087d75
Added copyrights to gameServer directory
Gianfranco Costamagna <costamagnagianfranco@yahoo.it>
parents:
10215
diff
changeset
|
15 |
* along with this program; if not, write to the Free Software |
8dcea9087d75
Added copyrights to gameServer directory
Gianfranco Costamagna <costamagnagianfranco@yahoo.it>
parents:
10215
diff
changeset
|
16 |
* Foundation, Inc., 51 Franklin Street, Fifth Floor, Boston, MA 02110-1301 USA. |
8dcea9087d75
Added copyrights to gameServer directory
Gianfranco Costamagna <costamagnagianfranco@yahoo.it>
parents:
10215
diff
changeset
|
17 |
\-} |
8dcea9087d75
Added copyrights to gameServer directory
Gianfranco Costamagna <costamagnagianfranco@yahoo.it>
parents:
10215
diff
changeset
|
18 |
|
1804 | 19 |
module ServerCore where |
20 |
||
21 |
import Control.Concurrent |
|
22 |
import Control.Monad |
|
23 |
import System.Log.Logger |
|
4295
1f5604cd99be
This revision should, in theory, correctly merge 0.9.14 and tip, so that future merges of 0.9.14 should work properly
nemo
parents:
4242
diff
changeset
|
24 |
import Control.Monad.Reader |
1f5604cd99be
This revision should, in theory, correctly merge 0.9.14 and tip, so that future merges of 0.9.14 should work properly
nemo
parents:
4242
diff
changeset
|
25 |
import Control.Monad.State.Strict |
11471
4b5c7a5c49fd
Defer kicking to the time when everything is in consistent state
unc0rr
parents:
11046
diff
changeset
|
26 |
import Data.Set as Set hiding (null) |
4918
c6d3aec73f93
Add Unique field to Client structure, and use it to check for matching recieved account status with client
unc0rr
parents:
4904
diff
changeset
|
27 |
import Data.Unique |
5209
f7a610e2ef5f
On restart command close server socket and spawn new server, keep running until last client quits
unc0rr
parents:
5093
diff
changeset
|
28 |
import Data.Maybe |
1804 | 29 |
-------------------------------------- |
30 |
import CoreTypes |
|
31 |
import NetRoutines |
|
32 |
import Actions |
|
1833 | 33 |
import OfficialServer.DBInteraction |
4295
1f5604cd99be
This revision should, in theory, correctly merge 0.9.14 and tip, so that future merges of 0.9.14 should work properly
nemo
parents:
4242
diff
changeset
|
34 |
import ServerState |
1927
e2031906a347
Ping clients every 30 seconds. Disconnection due to ping timeout to be implemented.
unc0rr
parents:
1926
diff
changeset
|
35 |
|
1839
5dd4cb7fd7e5
Server now send ASKPASSWORD command to frontend when user has web account
unc0rr
parents:
1833
diff
changeset
|
36 |
|
4295
1f5604cd99be
This revision should, in theory, correctly merge 0.9.14 and tip, so that future merges of 0.9.14 should work properly
nemo
parents:
4242
diff
changeset
|
37 |
timerLoop :: Int -> Chan CoreMessage -> IO () |
4612 | 38 |
timerLoop tick messagesChan = threadDelay 30000000 >> writeChan messagesChan (TimerAction tick) >> timerLoop (tick + 1) messagesChan |
4242 | 39 |
|
40 |
||
4989 | 41 |
mainLoop :: StateT ServerState IO () |
4295
1f5604cd99be
This revision should, in theory, correctly merge 0.9.14 and tip, so that future merges of 0.9.14 should work properly
nemo
parents:
4242
diff
changeset
|
42 |
mainLoop = forever $ do |
4955 | 43 |
-- get >>= \s -> put $! s |
4295
1f5604cd99be
This revision should, in theory, correctly merge 0.9.14 and tip, so that future merges of 0.9.14 should work properly
nemo
parents:
4242
diff
changeset
|
44 |
|
1f5604cd99be
This revision should, in theory, correctly merge 0.9.14 and tip, so that future merges of 0.9.14 should work properly
nemo
parents:
4242
diff
changeset
|
45 |
si <- gets serverInfo |
1f5604cd99be
This revision should, in theory, correctly merge 0.9.14 and tip, so that future merges of 0.9.14 should work properly
nemo
parents:
4242
diff
changeset
|
46 |
r <- liftIO $ readChan $ coreChan si |
1f5604cd99be
This revision should, in theory, correctly merge 0.9.14 and tip, so that future merges of 0.9.14 should work properly
nemo
parents:
4242
diff
changeset
|
47 |
|
1f5604cd99be
This revision should, in theory, correctly merge 0.9.14 and tip, so that future merges of 0.9.14 should work properly
nemo
parents:
4242
diff
changeset
|
48 |
case r of |
1f5604cd99be
This revision should, in theory, correctly merge 0.9.14 and tip, so that future merges of 0.9.14 should work properly
nemo
parents:
4242
diff
changeset
|
49 |
Accept ci -> processAction (AddClient ci) |
1f5604cd99be
This revision should, in theory, correctly merge 0.9.14 and tip, so that future merges of 0.9.14 should work properly
nemo
parents:
4242
diff
changeset
|
50 |
|
1f5604cd99be
This revision should, in theory, correctly merge 0.9.14 and tip, so that future merges of 0.9.14 should work properly
nemo
parents:
4242
diff
changeset
|
51 |
ClientMessage (ci, cmd) -> do |
4932 | 52 |
liftIO $ debugM "Clients" $ show ci ++ ": " ++ show cmd |
7529
058fcb451b37
Check if 'for' cycle body is executed at least once
unc0rr
parents:
5209
diff
changeset
|
53 |
|
4295
1f5604cd99be
This revision should, in theory, correctly merge 0.9.14 and tip, so that future merges of 0.9.14 should work properly
nemo
parents:
4242
diff
changeset
|
54 |
removed <- gets removedClients |
4932 | 55 |
unless (ci `Set.member` removed) $ do |
5093 | 56 |
modify (\s -> s{clientIndex = Just ci}) |
10212 | 57 |
processAction $ ReactCmd cmd |
11471
4b5c7a5c49fd
Defer kicking to the time when everything is in consistent state
unc0rr
parents:
11046
diff
changeset
|
58 |
pa <- client's pendingActions |
4b5c7a5c49fd
Defer kicking to the time when everything is in consistent state
unc0rr
parents:
11046
diff
changeset
|
59 |
when (not $ null pa) $ do |
4b5c7a5c49fd
Defer kicking to the time when everything is in consistent state
unc0rr
parents:
11046
diff
changeset
|
60 |
mapM_ processAction pa |
4b5c7a5c49fd
Defer kicking to the time when everything is in consistent state
unc0rr
parents:
11046
diff
changeset
|
61 |
processAction $ ModifyClient $ \c -> c{pendingActions = []} |
4295
1f5604cd99be
This revision should, in theory, correctly merge 0.9.14 and tip, so that future merges of 0.9.14 should work properly
nemo
parents:
4242
diff
changeset
|
62 |
|
4998
cdcdf37e5532
Send QUIT on exception too. This leads to double QUIT for a usual disconnection, yet is safe. Should fix crashes.
unc0rr
parents:
4989
diff
changeset
|
63 |
Remove ci -> |
4295
1f5604cd99be
This revision should, in theory, correctly merge 0.9.14 and tip, so that future merges of 0.9.14 should work properly
nemo
parents:
4242
diff
changeset
|
64 |
processAction (DeleteClient ci) |
3566 | 65 |
|
4918
c6d3aec73f93
Add Unique field to Client structure, and use it to check for matching recieved account status with client
unc0rr
parents:
4904
diff
changeset
|
66 |
ClientAccountInfo ci uid info -> do |
4295
1f5604cd99be
This revision should, in theory, correctly merge 0.9.14 and tip, so that future merges of 0.9.14 should work properly
nemo
parents:
4242
diff
changeset
|
67 |
rnc <- gets roomsClients |
1f5604cd99be
This revision should, in theory, correctly merge 0.9.14 and tip, so that future merges of 0.9.14 should work properly
nemo
parents:
4242
diff
changeset
|
68 |
exists <- liftIO $ clientExists rnc ci |
4932 | 69 |
when exists $ do |
5093 | 70 |
modify (\s -> s{clientIndex = Just ci}) |
4918
c6d3aec73f93
Add Unique field to Client structure, and use it to check for matching recieved account status with client
unc0rr
parents:
4904
diff
changeset
|
71 |
uid' <- client's clUID |
4932 | 72 |
when (uid == hashUnique uid') $ processAction (ProcessAccountInfo info) |
4295
1f5604cd99be
This revision should, in theory, correctly merge 0.9.14 and tip, so that future merges of 0.9.14 should work properly
nemo
parents:
4242
diff
changeset
|
73 |
return () |
3741
73246d25dfe1
Add some more strictness, use unsafeThaw and unsafeFreeze functions which work at O(1)
unc0rr
parents:
3673
diff
changeset
|
74 |
|
4295
1f5604cd99be
This revision should, in theory, correctly merge 0.9.14 and tip, so that future merges of 0.9.14 should work properly
nemo
parents:
4242
diff
changeset
|
75 |
TimerAction tick -> |
1f5604cd99be
This revision should, in theory, correctly merge 0.9.14 and tip, so that future merges of 0.9.14 should work properly
nemo
parents:
4242
diff
changeset
|
76 |
mapM_ processAction $ |
10017 | 77 |
PingAll |
10215 | 78 |
: CheckVotes |
10017 | 79 |
: [StatsAction | even tick] |
9973
7589978c9912
Stub for joins monitor which is a replacement to plain ban for 10 seconds system after join
unc0rr
parents:
7766
diff
changeset
|
80 |
++ [Cleanup | tick `mod` 100 == 0] |
4568 | 81 |
|
3741
73246d25dfe1
Add some more strictness, use unsafeThaw and unsafeFreeze functions which work at O(1)
unc0rr
parents:
3673
diff
changeset
|
82 |
|
5209
f7a610e2ef5f
On restart command close server socket and spawn new server, keep running until last client quits
unc0rr
parents:
5093
diff
changeset
|
83 |
startServer :: ServerInfo -> IO () |
f7a610e2ef5f
On restart command close server socket and spawn new server, keep running until last client quits
unc0rr
parents:
5093
diff
changeset
|
84 |
startServer si = do |
f7a610e2ef5f
On restart command close server socket and spawn new server, keep running until last client quits
unc0rr
parents:
5093
diff
changeset
|
85 |
noticeM "Core" $ "Listening on port " ++ show (listenPort si) |
1804 | 86 |
|
4932 | 87 |
_ <- forkIO $ |
2867
9be6693c78cb
- Unbreak support for client versions prior to 0.9.13-dev
unc0rr
parents:
2349
diff
changeset
|
88 |
acceptLoop |
5209
f7a610e2ef5f
On restart command close server socket and spawn new server, keep running until last client quits
unc0rr
parents:
5093
diff
changeset
|
89 |
(fromJust $ serverSocket si) |
4612 | 90 |
(coreChan si) |
1804 | 91 |
|
4932 | 92 |
_ <- forkIO $ timerLoop 0 $ coreChan si |
1804 | 93 |
|
4612 | 94 |
startDBConnection si |
1804 | 95 |
|
4295
1f5604cd99be
This revision should, in theory, correctly merge 0.9.14 and tip, so that future merges of 0.9.14 should work properly
nemo
parents:
4242
diff
changeset
|
96 |
rnc <- newRoomsAndClients newRoom |
9973
7589978c9912
Stub for joins monitor which is a replacement to plain ban for 10 seconds system after join
unc0rr
parents:
7766
diff
changeset
|
97 |
jm <- newJoinMonitor |
1804 | 98 |
|
9973
7589978c9912
Stub for joins monitor which is a replacement to plain ban for 10 seconds system after join
unc0rr
parents:
7766
diff
changeset
|
99 |
evalStateT mainLoop (ServerState Nothing si Set.empty rnc jm) |