gameServer/ServerCore.hs
author Wuzzy <almikes@aol.com>
Mon, 25 Sep 2017 20:46:26 +0200
changeset 12526 1877ca9e8703
parent 11471 4b5c7a5c49fd
permissions -rw-r--r--
Remove checkpoints in ASA: Searching in the dust Same rationale as for ASA: Getting to the device
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
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
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
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
772a46ef8288 Properly handle client exit
unc0rr
parents: 3500
diff changeset
    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
f11d80bac7ed - Take into account hlint suggestions
unc0rr
parents: 4918
diff changeset
    69
            when exists $ do
5093
7eb35faa7f7a Some polishing
unc0rr
parents: 4998
diff changeset
    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
f11d80bac7ed - Take into account hlint suggestions
unc0rr
parents: 4918
diff changeset
    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
de822cd3df3a fixwhitespace and dos2unix
koda
parents: 9973
diff changeset
    77
                    PingAll
10215
26fc5502ba22 - Fix applying vote result
unc0rr
parents: 10212
diff changeset
    78
                    : CheckVotes
10017
de822cd3df3a fixwhitespace and dos2unix
koda
parents: 9973
diff changeset
    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
f85243bf890e Ok. This should pull 0.9.14.1 server into default
nemo
parents: 4295
diff changeset
    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
4e78ad846fb6 New game server:
unc0rr
parents:
diff changeset
    86
4932
f11d80bac7ed - Take into account hlint suggestions
unc0rr
parents: 4918
diff changeset
    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
e82758d6f924 - Reactivate pings timer, reimplement PING handler
unc0rr
parents: 4597
diff changeset
    90
            (coreChan si)
1804
4e78ad846fb6 New game server:
unc0rr
parents:
diff changeset
    91
4932
f11d80bac7ed - Take into account hlint suggestions
unc0rr
parents: 4918
diff changeset
    92
    _ <- forkIO $ timerLoop 0 $ coreChan si
1804
4e78ad846fb6 New game server:
unc0rr
parents:
diff changeset
    93
4612
e82758d6f924 - Reactivate pings timer, reimplement PING handler
unc0rr
parents: 4597
diff changeset
    94
    startDBConnection si
1804
4e78ad846fb6 New game server:
unc0rr
parents:
diff changeset
    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
4e78ad846fb6 New game server:
unc0rr
parents:
diff changeset
    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)