gameServer/ServerCore.hs
author antonc27 <antonc27@mail.ru>
Mon, 09 Nov 2015 05:02:53 +0100
branchios-revival
changeset 11327 a0163b8302c5
parent 11046 47a8c19ecb60
child 11466 4b5c7a5c49fd
permissions -rw-r--r--
- Fix for wrong footer labels size on autorotation on GameConfig screen
Ignore whitespace changes - Everywhere: Within whitespace: At end of lines:
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
47a8c19ecb60 more copyright fixes
sheepluva
parents: 10460
diff changeset
     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
4e78ad846fb6 New game server:
unc0rr
parents:
diff changeset
    19
module ServerCore where
4e78ad846fb6 New game server:
unc0rr
parents:
diff changeset
    20
4e78ad846fb6 New game server:
unc0rr
parents:
diff changeset
    21
import Control.Concurrent
4e78ad846fb6 New game server:
unc0rr
parents:
diff changeset
    22
import Control.Monad
4e78ad846fb6 New game server:
unc0rr
parents:
diff changeset
    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
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
    26
import Data.Set as Set
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
4e78ad846fb6 New game server:
unc0rr
parents:
diff changeset
    29
--------------------------------------
4e78ad846fb6 New game server:
unc0rr
parents:
diff changeset
    30
import CoreTypes
4e78ad846fb6 New game server:
unc0rr
parents:
diff changeset
    31
import NetRoutines
4e78ad846fb6 New game server:
unc0rr
parents:
diff changeset
    32
import Actions
1833
e901ec5644b4 Add options for configuring database access
unc0rr
parents: 1804
diff changeset
    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
e82758d6f924 - Reactivate pings timer, reimplement PING handler
unc0rr
parents: 4597
diff changeset
    38
timerLoop tick messagesChan = threadDelay 30000000 >> writeChan messagesChan (TimerAction tick) >> timerLoop (tick + 1) messagesChan
4242
5e3c5fe2cb14 Revert to old server in branch 0.9.14
unc0rr
parents: 3947
diff changeset
    39
5e3c5fe2cb14 Revert to old server in branch 0.9.14
unc0rr
parents: 3947
diff changeset
    40
4989
4771fed9272e - Write server config into .ini file on change
unc0rr
parents: 4975
diff changeset
    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
84543ecae8c3 Don't forkIO main loop
unc0rr
parents: 4932
diff changeset
    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
f11d80bac7ed - Take into account hlint suggestions
unc0rr
parents: 4918
diff changeset
    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
f11d80bac7ed - Take into account hlint suggestions
unc0rr
parents: 4918
diff changeset
    55
            unless (ci `Set.member` removed) $ do
5093
7eb35faa7f7a Some polishing
unc0rr
parents: 4998
diff changeset
    56
                modify (\s -> s{clientIndex = Just ci})
10212
5fb3bb2de9d2 Some fixes to voting + small refactoring
unc0rr
parents: 10017
diff changeset
    57
                processAction $ ReactCmd cmd
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
    58
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
    59
        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
    60
            processAction (DeleteClient ci)
3566
772a46ef8288 Properly handle client exit
unc0rr
parents: 3500
diff changeset
    61
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
    62
        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
    63
            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
    64
            exists <- liftIO $ clientExists rnc ci
4932
f11d80bac7ed - Take into account hlint suggestions
unc0rr
parents: 4918
diff changeset
    65
            when exists $ do
5093
7eb35faa7f7a Some polishing
unc0rr
parents: 4998
diff changeset
    66
                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
    67
                uid' <- client's clUID
4932
f11d80bac7ed - Take into account hlint suggestions
unc0rr
parents: 4918
diff changeset
    68
                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
    69
                return ()
3741
73246d25dfe1 Add some more strictness, use unsafeThaw and unsafeFreeze functions which work at O(1)
unc0rr
parents: 3673
diff changeset
    70
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
    71
        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
    72
                mapM_ processAction $
10017
de822cd3df3a fixwhitespace and dos2unix
koda
parents: 9973
diff changeset
    73
                    PingAll
10215
26fc5502ba22 - Fix applying vote result
unc0rr
parents: 10212
diff changeset
    74
                    : CheckVotes
10017
de822cd3df3a fixwhitespace and dos2unix
koda
parents: 9973
diff changeset
    75
                    : [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
    76
                    ++ [Cleanup | tick `mod` 100 == 0]
4568
f85243bf890e Ok. This should pull 0.9.14.1 server into default
nemo
parents: 4295
diff changeset
    77
3741
73246d25dfe1 Add some more strictness, use unsafeThaw and unsafeFreeze functions which work at O(1)
unc0rr
parents: 3673
diff changeset
    78
5209
f7a610e2ef5f On restart command close server socket and spawn new server, keep running until last client quits
unc0rr
parents: 5093
diff changeset
    79
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
    80
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
    81
    noticeM "Core" $ "Listening on port " ++ show (listenPort si)
1804
4e78ad846fb6 New game server:
unc0rr
parents:
diff changeset
    82
4932
f11d80bac7ed - Take into account hlint suggestions
unc0rr
parents: 4918
diff changeset
    83
    _ <- forkIO $
2867
9be6693c78cb - Unbreak support for client versions prior to 0.9.13-dev
unc0rr
parents: 2349
diff changeset
    84
        acceptLoop
5209
f7a610e2ef5f On restart command close server socket and spawn new server, keep running until last client quits
unc0rr
parents: 5093
diff changeset
    85
            (fromJust $ serverSocket si)
4612
e82758d6f924 - Reactivate pings timer, reimplement PING handler
unc0rr
parents: 4597
diff changeset
    86
            (coreChan si)
1804
4e78ad846fb6 New game server:
unc0rr
parents:
diff changeset
    87
4932
f11d80bac7ed - Take into account hlint suggestions
unc0rr
parents: 4918
diff changeset
    88
    _ <- forkIO $ timerLoop 0 $ coreChan si
1804
4e78ad846fb6 New game server:
unc0rr
parents:
diff changeset
    89
4612
e82758d6f924 - Reactivate pings timer, reimplement PING handler
unc0rr
parents: 4597
diff changeset
    90
    startDBConnection si
1804
4e78ad846fb6 New game server:
unc0rr
parents:
diff changeset
    91
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
    92
    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
    93
    jm <- newJoinMonitor
1804
4e78ad846fb6 New game server:
unc0rr
parents:
diff changeset
    94
9973
7589978c9912 Stub for joins monitor which is a replacement to plain ban for 10 seconds system after join
unc0rr
parents: 7766
diff changeset
    95
    evalStateT mainLoop (ServerState Nothing si Set.empty rnc jm)