gameServer/HWProtoCore.hs
author nemo
Thu, 20 Mar 2014 13:12:05 -0400
changeset 10210 1a6b9a98147c
parent 10195 d1c23bb73346
child 10212 5fb3bb2de9d2
permissions -rw-r--r--
hm. I think I forgot to commit this when adding speech bubble change
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
1804
4e78ad846fb6 New game server:
unc0rr
parents:
diff changeset
     7
--------------------------------------
4e78ad846fb6 New game server:
unc0rr
parents:
diff changeset
     8
import CoreTypes
4e78ad846fb6 New game server:
unc0rr
parents:
diff changeset
     9
import Actions
4e78ad846fb6 New game server:
unc0rr
parents:
diff changeset
    10
import HWProtoNEState
4e78ad846fb6 New game server:
unc0rr
parents:
diff changeset
    11
import HWProtoLobbyState
4e78ad846fb6 New game server:
unc0rr
parents:
diff changeset
    12
import HWProtoInRoomState
8479
8d71109b04d2 Some work on loading replay and interaction with checker
unc0rr
parents: 8478
diff changeset
    13
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
    14
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
    15
import RoomsAndClients
4612
e82758d6f924 - Reactivate pings timer, reimplement PING handler
unc0rr
parents: 4337
diff changeset
    16
import Utils
1804
4e78ad846fb6 New game server:
unc0rr
parents:
diff changeset
    17
4989
4771fed9272e - Write server config into .ini file on change
unc0rr
parents: 4975
diff changeset
    18
handleCmd, handleCmd_loggedin :: CmdHandler
1804
4e78ad846fb6 New game server:
unc0rr
parents:
diff changeset
    19
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
    20
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
handleCmd ["PING"] = answerClient ["PONG"]
1804
4e78ad846fb6 New game server:
unc0rr
parents:
diff changeset
    22
4e78ad846fb6 New game server:
unc0rr
parents:
diff changeset
    23
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
handleCmd ("QUIT" : xs) = return [ByeClient msg]
2867
9be6693c78cb - Unbreak support for client versions prior to 0.9.13-dev
unc0rr
parents: 2706
diff changeset
    25
    where
8401
87410ae372f6 Server messages localization using Qt's l10n subsystem:
unc0rr
parents: 8396
diff changeset
    26
        msg = if not $ null xs then head xs else loc "bye"
1804
4e78ad846fb6 New game server:
unc0rr
parents:
diff changeset
    27
4568
f85243bf890e Ok. This should pull 0.9.14.1 server into default
nemo
parents: 4337
diff changeset
    28
4612
e82758d6f924 - Reactivate pings timer, reimplement PING handler
unc0rr
parents: 4337
diff changeset
    29
handleCmd ["PONG"] = do
e82758d6f924 - Reactivate pings timer, reimplement PING handler
unc0rr
parents: 4337
diff changeset
    30
    cl <- thisClient
e82758d6f924 - Reactivate pings timer, reimplement PING handler
unc0rr
parents: 4337
diff changeset
    31
    if pingsQueue cl == 0 then
8897
d6c310c65c91 - Revert server workaround over desync from r98e2dbdda8c0
unc0rr
parents: 8547
diff changeset
    32
        return [ProtocolError "Protocol violation"]
4612
e82758d6f924 - Reactivate pings timer, reimplement PING handler
unc0rr
parents: 4337
diff changeset
    33
        else
e82758d6f924 - Reactivate pings timer, reimplement PING handler
unc0rr
parents: 4337
diff changeset
    34
        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
    35
10039
58cf89284115 Halfplement voting
unc0rr
parents: 9787
diff changeset
    36
handleCmd ["CMD", parameters] = uncurry h $ extractParameters parameters
8396
5123eac2f9d6 - Pass unknown chat commands to server
unc0rr
parents: 7766
diff changeset
    37
    where
9105
18ebb59c89fe Proper parameters handling of chat commands
unc0rr
parents: 9061
diff changeset
    38
        h "DELEGATE" n | not $ B.null n = handleCmd ["DELEGATE", n]
10195
d1c23bb73346 - Room save/load into/from file
unc0rr
parents: 10194
diff changeset
    39
        h "SAVEROOM" n | not $ B.null n = handleCmd ["SAVEROOM", n]
d1c23bb73346 - Room save/load into/from file
unc0rr
parents: 10194
diff changeset
    40
        h "LOADROOM" n | not $ B.null n = handleCmd ["LOADROOM", n]
10194
7025bd3c3131 Allow to save and delete room config in room
unc0rr
parents: 10061
diff changeset
    41
        h "SAVE" n | not $ B.null n = handleCmd ["SAVE", n]
7025bd3c3131 Allow to save and delete room config in room
unc0rr
parents: 10061
diff changeset
    42
        h "DELETE" n | not $ B.null n = handleCmd ["DELETE", n]
9105
18ebb59c89fe Proper parameters handling of chat commands
unc0rr
parents: 9061
diff changeset
    43
        h "STATS" _ = handleCmd ["STATS"]
18ebb59c89fe Proper parameters handling of chat commands
unc0rr
parents: 9061
diff changeset
    44
        h "PART" m | not $ B.null m = handleCmd ["PART", m]
18ebb59c89fe Proper parameters handling of chat commands
unc0rr
parents: 9061
diff changeset
    45
                   | otherwise = handleCmd ["PART"]
18ebb59c89fe Proper parameters handling of chat commands
unc0rr
parents: 9061
diff changeset
    46
        h "QUIT" m | not $ B.null m = handleCmd ["QUIT", m]
18ebb59c89fe Proper parameters handling of chat commands
unc0rr
parents: 9061
diff changeset
    47
                   | otherwise = handleCmd ["QUIT"]
18ebb59c89fe Proper parameters handling of chat commands
unc0rr
parents: 9061
diff changeset
    48
        h "RND" p = handleCmd ("RND" : B.words p)
18ebb59c89fe Proper parameters handling of chat commands
unc0rr
parents: 9061
diff changeset
    49
        h "GLOBAL" p = 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
9105
18ebb59c89fe Proper parameters handling of chat commands
unc0rr
parents: 9061
diff changeset
    53
            return [AnswerClients chans ["CHAT", "[global notice]", p] | isAdministrator cl]
9448
04e0acfa7c2c /watch works in testing environment
unc0rr
parents: 9446
diff changeset
    54
        h "WATCH" f = return [QueryReplay f]
9753
9579596cf471 - Special rooms which stay even when last player quits. Not useful for now, and can't be removed at all.
unc0rr
parents: 9448
diff changeset
    55
        h "FIX" _ = handleCmd ["FIX"]
9770
5706b637bae2 - Restrict game config changes in special rooms
unc0rr
parents: 9753
diff changeset
    56
        h "UNFIX" _ = handleCmd ["UNFIX"]
9787
0da6ba2f1f93 - /greeting command for room greeting message
unc0rr
parents: 9770
diff changeset
    57
        h "GREETING" msg = handleCmd ["GREETING", msg]
10039
58cf89284115 Halfplement voting
unc0rr
parents: 9787
diff changeset
    58
        h "CALLVOTE" msg | B.null msg = handleCmd ["CALLVOTE"]
58cf89284115 Halfplement voting
unc0rr
parents: 9787
diff changeset
    59
                         | otherwise = let (c, p) = extractParameters msg in
58cf89284115 Halfplement voting
unc0rr
parents: 9787
diff changeset
    60
                                           if B.null p then handleCmd ["CALLVOTE", c] else handleCmd ["CALLVOTE", c, p]
58cf89284115 Halfplement voting
unc0rr
parents: 9787
diff changeset
    61
        h "VOTE" msg = handleCmd ["VOTE", upperCase msg]
10195
d1c23bb73346 - Room save/load into/from file
unc0rr
parents: 10194
diff changeset
    62
        h c p = return [Warning $ B.concat ["Unknown cmd: /", c, " ", p]]
8396
5123eac2f9d6 - Pass unknown chat commands to server
unc0rr
parents: 7766
diff changeset
    63
10039
58cf89284115 Halfplement voting
unc0rr
parents: 9787
diff changeset
    64
        extractParameters p = let (a, b) = B.break (== ' ') p in (upperCase a, B.dropWhile (== ' ') b)
58cf89284115 Halfplement voting
unc0rr
parents: 9787
diff changeset
    65
58cf89284115 Halfplement voting
unc0rr
parents: 9787
diff changeset
    66
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
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
    68
    (ci, irnc) <- ask
8479
8d71109b04d2 Some work on loading replay and interaction with checker
unc0rr
parents: 8478
diff changeset
    69
    let cl = irnc `client` ci
8d71109b04d2 Some work on loading replay and interaction with checker
unc0rr
parents: 8478
diff changeset
    70
    if logonPassed cl then
8d71109b04d2 Some work on loading replay and interaction with checker
unc0rr
parents: 8478
diff changeset
    71
        if isChecker cl then
8d71109b04d2 Some work on loading replay and interaction with checker
unc0rr
parents: 8478
diff changeset
    72
            handleCmd_checker cmd
8d71109b04d2 Some work on loading replay and interaction with checker
unc0rr
parents: 8478
diff changeset
    73
            else
8d71109b04d2 Some work on loading replay and interaction with checker
unc0rr
parents: 8478
diff changeset
    74
            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
    75
        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
    76
        handleCmd_NotEntered cmd
1862
7f303aa066da Implement kick from server by administrator
unc0rr
parents: 1841
diff changeset
    77
4568
f85243bf890e Ok. This should pull 0.9.14.1 server into default
nemo
parents: 4337
diff changeset
    78
4612
e82758d6f924 - Reactivate pings timer, reimplement PING handler
unc0rr
parents: 4337
diff changeset
    79
handleCmd_loggedin ["INFO", asknick] = do
e82758d6f924 - Reactivate pings timer, reimplement PING handler
unc0rr
parents: 4337
diff changeset
    80
    (_, rnc) <- ask
4614
26661bf28dd5 Reimplement some more protocol commands
unc0rr
parents: 4612
diff changeset
    81
    maybeClientId <- clientByNick asknick
5060
7d0f6e5b1c1c Hide last two octets of IP address from usual users
unc0rr
parents: 5030
diff changeset
    82
    isAdminAsking <- liftM isAdministrator thisClient
4612
e82758d6f924 - Reactivate pings timer, reimplement PING handler
unc0rr
parents: 4337
diff changeset
    83
    let noSuchClient = isNothing maybeClientId
e82758d6f924 - Reactivate pings timer, reimplement PING handler
unc0rr
parents: 4337
diff changeset
    84
    let clientId = fromJust maybeClientId
e82758d6f924 - Reactivate pings timer, reimplement PING handler
unc0rr
parents: 4337
diff changeset
    85
    let cl = rnc `client` fromJust maybeClientId
e82758d6f924 - Reactivate pings timer, reimplement PING handler
unc0rr
parents: 4337
diff changeset
    86
    let roomId = clientRoom rnc clientId
e82758d6f924 - Reactivate pings timer, reimplement PING handler
unc0rr
parents: 4337
diff changeset
    87
    let clRoom = room rnc roomId
9061
38e8787483db '@' for server admin status, '+' for room admins
unc0rr
parents: 9035
diff changeset
    88
    let roomMasterSign = if isMaster cl then "+" else ""
4612
e82758d6f924 - Reactivate pings timer, reimplement PING handler
unc0rr
parents: 4337
diff changeset
    89
    let adminSign = if isAdministrator cl then "@" else ""
9061
38e8787483db '@' for server admin status, '+' for room admins
unc0rr
parents: 9035
diff changeset
    90
    let rInfo = if roomId /= lobbyId then B.concat [adminSign, 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
    91
    let roomStatus = if isJust $ gameInfo clRoom then
4612
e82758d6f924 - Reactivate pings timer, reimplement PING handler
unc0rr
parents: 4337
diff changeset
    92
            if teamsInGame cl > 0 then "(playing)" else "(spectating)"
e82758d6f924 - Reactivate pings timer, reimplement PING handler
unc0rr
parents: 4337
diff changeset
    93
            else
e82758d6f924 - Reactivate pings timer, reimplement PING handler
unc0rr
parents: 4337
diff changeset
    94
            ""
10061
b7161f00a6ca hide complete IP of other users, when non-admin requests player info. showing the first two parts of the IP was kinda pointless to begin with (what for?) and has recently lead to increased abuse and lobby flooding due to bots collecting/posting IP tracking information
sheepluva
parents: 10039
diff changeset
    95
    let hostStr = if isAdminAsking then host cl else B.empty
2867
9be6693c78cb - Unbreak support for client versions prior to 0.9.13-dev
unc0rr
parents: 2706
diff changeset
    96
    if noSuchClient then
4612
e82758d6f924 - Reactivate pings timer, reimplement PING handler
unc0rr
parents: 4337
diff changeset
    97
        return []
e82758d6f924 - Reactivate pings timer, reimplement PING handler
unc0rr
parents: 4337
diff changeset
    98
        else
e82758d6f924 - Reactivate pings timer, reimplement PING handler
unc0rr
parents: 4337
diff changeset
    99
        answerClient [
e82758d6f924 - Reactivate pings timer, reimplement PING handler
unc0rr
parents: 4337
diff changeset
   100
            "INFO",
e82758d6f924 - Reactivate pings timer, reimplement PING handler
unc0rr
parents: 4337
diff changeset
   101
            nick cl,
5060
7d0f6e5b1c1c Hide last two octets of IP address from usual users
unc0rr
parents: 5030
diff changeset
   102
            B.concat ["[", hostStr, "]"],
4612
e82758d6f924 - Reactivate pings timer, reimplement PING handler
unc0rr
parents: 4337
diff changeset
   103
            protoNumber2ver $ clientProto cl,
7766
98edc0724a28 Fix most of server warnings
unc0rr
parents: 5996
diff changeset
   104
            B.concat ["[", rInfo, "]", roomStatus]
4612
e82758d6f924 - Reactivate pings timer, reimplement PING handler
unc0rr
parents: 4337
diff changeset
   105
            ]
1862
7f303aa066da Implement kick from server by administrator
unc0rr
parents: 1841
diff changeset
   106
7f303aa066da Implement kick from server by administrator
unc0rr
parents: 1841
diff changeset
   107
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
   108
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
   109
    (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
   110
    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
   111
        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
   112
        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
   113
        handleCmd_inRoom cmd