gameServer/HWProtoCore.hs
author nemo
Wed, 22 May 2013 09:46:42 -0400
changeset 9045 6561c42399d3
parent 9035 e84d42a4311c
child 9061 38e8787483db
permissions -rw-r--r--
sheepluva suggestion for frozen barrel behaviour. untested.
Ignore whitespace changes - Everywhere: Within whitespace: At end of lines:
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
     1
{-# LANGUAGE OverloadedStrings #-}
1804
4e78ad846fb6 New game server:
unc0rr
parents:
diff changeset
     2
module HWProtoCore where
4e78ad846fb6 New game server:
unc0rr
parents:
diff changeset
     3
4612
e82758d6f924 - Reactivate pings timer, reimplement PING handler
unc0rr
parents: 4337
diff changeset
     4
import Control.Monad.Reader
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
     5
import Data.Maybe
4612
e82758d6f924 - Reactivate pings timer, reimplement PING handler
unc0rr
parents: 4337
diff changeset
     6
import qualified Data.ByteString.Char8 as B
8396
5123eac2f9d6 - Pass unknown chat commands to server
unc0rr
parents: 7766
diff changeset
     7
import qualified Data.List as L
1804
4e78ad846fb6 New game server:
unc0rr
parents:
diff changeset
     8
--------------------------------------
4e78ad846fb6 New game server:
unc0rr
parents:
diff changeset
     9
import CoreTypes
4e78ad846fb6 New game server:
unc0rr
parents:
diff changeset
    10
import Actions
4e78ad846fb6 New game server:
unc0rr
parents:
diff changeset
    11
import HWProtoNEState
4e78ad846fb6 New game server:
unc0rr
parents:
diff changeset
    12
import HWProtoLobbyState
4e78ad846fb6 New game server:
unc0rr
parents:
diff changeset
    13
import HWProtoInRoomState
8479
8d71109b04d2 Some work on loading replay and interaction with checker
unc0rr
parents: 8478
diff changeset
    14
import HWProtoChecker
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
    15
import HandlerUtils
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
    16
import RoomsAndClients
4612
e82758d6f924 - Reactivate pings timer, reimplement PING handler
unc0rr
parents: 4337
diff changeset
    17
import Utils
1804
4e78ad846fb6 New game server:
unc0rr
parents:
diff changeset
    18
4989
4771fed9272e - Write server config into .ini file on change
unc0rr
parents: 4975
diff changeset
    19
handleCmd, handleCmd_loggedin :: CmdHandler
1804
4e78ad846fb6 New game server:
unc0rr
parents:
diff changeset
    20
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
    21
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
    22
handleCmd ["PING"] = answerClient ["PONG"]
1804
4e78ad846fb6 New game server:
unc0rr
parents:
diff changeset
    23
4e78ad846fb6 New game server:
unc0rr
parents:
diff changeset
    24
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
    25
handleCmd ("QUIT" : xs) = return [ByeClient msg]
2867
9be6693c78cb - Unbreak support for client versions prior to 0.9.13-dev
unc0rr
parents: 2706
diff changeset
    26
    where
8401
87410ae372f6 Server messages localization using Qt's l10n subsystem:
unc0rr
parents: 8396
diff changeset
    27
        msg = if not $ null xs then head xs else loc "bye"
1804
4e78ad846fb6 New game server:
unc0rr
parents:
diff changeset
    28
4568
f85243bf890e Ok. This should pull 0.9.14.1 server into default
nemo
parents: 4337
diff changeset
    29
4612
e82758d6f924 - Reactivate pings timer, reimplement PING handler
unc0rr
parents: 4337
diff changeset
    30
handleCmd ["PONG"] = do
e82758d6f924 - Reactivate pings timer, reimplement PING handler
unc0rr
parents: 4337
diff changeset
    31
    cl <- thisClient
e82758d6f924 - Reactivate pings timer, reimplement PING handler
unc0rr
parents: 4337
diff changeset
    32
    if pingsQueue cl == 0 then
8897
d6c310c65c91 - Revert server workaround over desync from r98e2dbdda8c0
unc0rr
parents: 8547
diff changeset
    33
        return [ProtocolError "Protocol violation"]
4612
e82758d6f924 - Reactivate pings timer, reimplement PING handler
unc0rr
parents: 4337
diff changeset
    34
        else
e82758d6f924 - Reactivate pings timer, reimplement PING handler
unc0rr
parents: 4337
diff changeset
    35
        return [ModifyClient (\c -> c{pingsQueue = pingsQueue c - 1})]
4568
f85243bf890e Ok. This should pull 0.9.14.1 server into default
nemo
parents: 4337
diff changeset
    36
8547
6898be8aa261 Global notice with /global command. Can now warn users when doing server restart.
unc0rr
parents: 8519
diff changeset
    37
handleCmd ("CMD" : parameters) =
6898be8aa261 Global notice with /global command. Can now warn users when doing server restart.
unc0rr
parents: 8519
diff changeset
    38
    let c = concatMap B.words parameters in
8396
5123eac2f9d6 - Pass unknown chat commands to server
unc0rr
parents: 7766
diff changeset
    39
        if not $ null c then
5123eac2f9d6 - Pass unknown chat commands to server
unc0rr
parents: 7766
diff changeset
    40
            h $ (upperCase . head $ c) : tail c
5123eac2f9d6 - Pass unknown chat commands to server
unc0rr
parents: 7766
diff changeset
    41
            else
5123eac2f9d6 - Pass unknown chat commands to server
unc0rr
parents: 7766
diff changeset
    42
            return []
5123eac2f9d6 - Pass unknown chat commands to server
unc0rr
parents: 7766
diff changeset
    43
    where
5123eac2f9d6 - Pass unknown chat commands to server
unc0rr
parents: 7766
diff changeset
    44
        h ["DELEGATE", n] = handleCmd ["DELEGATE", n]
8403
fbc6e7602e05 - Allow server admins to use DELEGATE even when not room owner
unc0rr
parents: 8401
diff changeset
    45
        h ["STATS"] = handleCmd ["STATS"]
9034
279168729cc3 Allow messages containing word separators in server's additional console commands
unc0rr
parents: 8897
diff changeset
    46
        h ("PART":m:ms) = handleCmd ["PART", B.unwords $ m:ms]
279168729cc3 Allow messages containing word separators in server's additional console commands
unc0rr
parents: 8897
diff changeset
    47
        h ("QUIT":m:ms) = handleCmd ["QUIT", B.unwords $ m:ms]
9035
e84d42a4311c '/rnd' command. Pass it a (possibly empty) list of items.
unc0rr
parents: 9034
diff changeset
    48
        h ("RND":rs) = handleCmd ("RND":rs)
9034
279168729cc3 Allow messages containing word separators in server's additional console commands
unc0rr
parents: 8897
diff changeset
    49
        h ("GLOBAL":m:ms) = do
9035
e84d42a4311c '/rnd' command. Pass it a (possibly empty) list of items.
unc0rr
parents: 9034
diff changeset
    50
            cl <- thisClient
8547
6898be8aa261 Global notice with /global command. Can now warn users when doing server restart.
unc0rr
parents: 8519
diff changeset
    51
            rnc <- liftM snd ask
6898be8aa261 Global notice with /global command. Can now warn users when doing server restart.
unc0rr
parents: 8519
diff changeset
    52
            let chans = map (sendChan . client rnc) $ allClients rnc
9035
e84d42a4311c '/rnd' command. Pass it a (possibly empty) list of items.
unc0rr
parents: 9034
diff changeset
    53
            return [AnswerClients chans ["CHAT", "[global notice]", B.unwords $ m:ms] | isAdministrator cl]
8396
5123eac2f9d6 - Pass unknown chat commands to server
unc0rr
parents: 7766
diff changeset
    54
        h c = return [Warning . B.concat . L.intersperse " " $ "Unknown cmd" : c]
5123eac2f9d6 - Pass unknown chat commands to server
unc0rr
parents: 7766
diff changeset
    55
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
    56
handleCmd cmd = do
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
    57
    (ci, irnc) <- ask
8479
8d71109b04d2 Some work on loading replay and interaction with checker
unc0rr
parents: 8478
diff changeset
    58
    let cl = irnc `client` ci
8d71109b04d2 Some work on loading replay and interaction with checker
unc0rr
parents: 8478
diff changeset
    59
    if logonPassed cl then
8d71109b04d2 Some work on loading replay and interaction with checker
unc0rr
parents: 8478
diff changeset
    60
        if isChecker cl then
8d71109b04d2 Some work on loading replay and interaction with checker
unc0rr
parents: 8478
diff changeset
    61
            handleCmd_checker cmd
8d71109b04d2 Some work on loading replay and interaction with checker
unc0rr
parents: 8478
diff changeset
    62
            else
8d71109b04d2 Some work on loading replay and interaction with checker
unc0rr
parents: 8478
diff changeset
    63
            handleCmd_loggedin 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
    64
        else
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
    65
        handleCmd_NotEntered cmd
1862
7f303aa066da Implement kick from server by administrator
unc0rr
parents: 1841
diff changeset
    66
4568
f85243bf890e Ok. This should pull 0.9.14.1 server into default
nemo
parents: 4337
diff changeset
    67
4612
e82758d6f924 - Reactivate pings timer, reimplement PING handler
unc0rr
parents: 4337
diff changeset
    68
handleCmd_loggedin ["INFO", asknick] = do
e82758d6f924 - Reactivate pings timer, reimplement PING handler
unc0rr
parents: 4337
diff changeset
    69
    (_, rnc) <- ask
4614
26661bf28dd5 Reimplement some more protocol commands
unc0rr
parents: 4612
diff changeset
    70
    maybeClientId <- clientByNick asknick
5060
7d0f6e5b1c1c Hide last two octets of IP address from usual users
unc0rr
parents: 5030
diff changeset
    71
    isAdminAsking <- liftM isAdministrator thisClient
4612
e82758d6f924 - Reactivate pings timer, reimplement PING handler
unc0rr
parents: 4337
diff changeset
    72
    let noSuchClient = isNothing maybeClientId
e82758d6f924 - Reactivate pings timer, reimplement PING handler
unc0rr
parents: 4337
diff changeset
    73
    let clientId = fromJust maybeClientId
e82758d6f924 - Reactivate pings timer, reimplement PING handler
unc0rr
parents: 4337
diff changeset
    74
    let cl = rnc `client` fromJust maybeClientId
e82758d6f924 - Reactivate pings timer, reimplement PING handler
unc0rr
parents: 4337
diff changeset
    75
    let roomId = clientRoom rnc clientId
e82758d6f924 - Reactivate pings timer, reimplement PING handler
unc0rr
parents: 4337
diff changeset
    76
    let clRoom = room rnc roomId
e82758d6f924 - Reactivate pings timer, reimplement PING handler
unc0rr
parents: 4337
diff changeset
    77
    let roomMasterSign = if isMaster cl then "@" else ""
e82758d6f924 - Reactivate pings timer, reimplement PING handler
unc0rr
parents: 4337
diff changeset
    78
    let adminSign = if isAdministrator cl then "@" else ""
7766
98edc0724a28 Fix most of server warnings
unc0rr
parents: 5996
diff changeset
    79
    let rInfo = if roomId /= lobbyId then B.concat [roomMasterSign, "room ", name clRoom] else adminSign `B.append` "lobby"
5996
2c72fe81dd37 Convert boolean variable + a bunch of fields which make sense only while game is going on into Maybe + structure
unc0rr
parents: 5060
diff changeset
    80
    let roomStatus = if isJust $ gameInfo clRoom then
4612
e82758d6f924 - Reactivate pings timer, reimplement PING handler
unc0rr
parents: 4337
diff changeset
    81
            if teamsInGame cl > 0 then "(playing)" else "(spectating)"
e82758d6f924 - Reactivate pings timer, reimplement PING handler
unc0rr
parents: 4337
diff changeset
    82
            else
e82758d6f924 - Reactivate pings timer, reimplement PING handler
unc0rr
parents: 4337
diff changeset
    83
            ""
5060
7d0f6e5b1c1c Hide last two octets of IP address from usual users
unc0rr
parents: 5030
diff changeset
    84
    let hostStr = if isAdminAsking then host cl else cutHost $ host cl
2867
9be6693c78cb - Unbreak support for client versions prior to 0.9.13-dev
unc0rr
parents: 2706
diff changeset
    85
    if noSuchClient then
4612
e82758d6f924 - Reactivate pings timer, reimplement PING handler
unc0rr
parents: 4337
diff changeset
    86
        return []
e82758d6f924 - Reactivate pings timer, reimplement PING handler
unc0rr
parents: 4337
diff changeset
    87
        else
e82758d6f924 - Reactivate pings timer, reimplement PING handler
unc0rr
parents: 4337
diff changeset
    88
        answerClient [
e82758d6f924 - Reactivate pings timer, reimplement PING handler
unc0rr
parents: 4337
diff changeset
    89
            "INFO",
e82758d6f924 - Reactivate pings timer, reimplement PING handler
unc0rr
parents: 4337
diff changeset
    90
            nick cl,
5060
7d0f6e5b1c1c Hide last two octets of IP address from usual users
unc0rr
parents: 5030
diff changeset
    91
            B.concat ["[", hostStr, "]"],
4612
e82758d6f924 - Reactivate pings timer, reimplement PING handler
unc0rr
parents: 4337
diff changeset
    92
            protoNumber2ver $ clientProto cl,
7766
98edc0724a28 Fix most of server warnings
unc0rr
parents: 5996
diff changeset
    93
            B.concat ["[", rInfo, "]", roomStatus]
4612
e82758d6f924 - Reactivate pings timer, reimplement PING handler
unc0rr
parents: 4337
diff changeset
    94
            ]
1862
7f303aa066da Implement kick from server by administrator
unc0rr
parents: 1841
diff changeset
    95
7f303aa066da Implement kick from server by administrator
unc0rr
parents: 1841
diff changeset
    96
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
    97
handleCmd_loggedin cmd = do
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
    98
    (ci, rnc) <- ask
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
    99
    if clientRoom rnc ci == lobbyId then
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
   100
        handleCmd_lobby cmd
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
   101
        else
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
   102
        handleCmd_inRoom cmd