gameServer/HWProtoCore.hs
author S.D.
Wed, 05 Oct 2022 22:39:07 +0300
changeset 15905 bf92592915c6
parent 14402 32e8c81ca35c
child 15909 7409084d891f
permissions -rw-r--r--
Add direct message server command (/msg <nick_name>|<[nick name]> <message>)
Ignore whitespace changes - Everywhere: Within whitespace: At end of lines:
10460
8dcea9087d75 Added copyrights to gameServer directory
Gianfranco Costamagna <costamagnagianfranco@yahoo.it>
parents: 10212
diff changeset
     1
{-
8dcea9087d75 Added copyrights to gameServer directory
Gianfranco Costamagna <costamagnagianfranco@yahoo.it>
parents: 10212
diff changeset
     2
 * Hedgewars, a free turn based strategy game
11046
47a8c19ecb60 more copyright fixes
sheepluva
parents: 11033
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: 10212
diff changeset
     4
 *
8dcea9087d75 Added copyrights to gameServer directory
Gianfranco Costamagna <costamagnagianfranco@yahoo.it>
parents: 10212
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: 10212
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: 10212
diff changeset
     7
 * the Free Software Foundation; version 2 of the License
8dcea9087d75 Added copyrights to gameServer directory
Gianfranco Costamagna <costamagnagianfranco@yahoo.it>
parents: 10212
diff changeset
     8
 *
8dcea9087d75 Added copyrights to gameServer directory
Gianfranco Costamagna <costamagnagianfranco@yahoo.it>
parents: 10212
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: 10212
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: 10212
diff changeset
    11
 * MERCHANTABILITY or FITNESS FOR A PARTICULAR PURPOSE.  See the
8dcea9087d75 Added copyrights to gameServer directory
Gianfranco Costamagna <costamagnagianfranco@yahoo.it>
parents: 10212
diff changeset
    12
 * GNU General Public License for more details.
8dcea9087d75 Added copyrights to gameServer directory
Gianfranco Costamagna <costamagnagianfranco@yahoo.it>
parents: 10212
diff changeset
    13
 *
8dcea9087d75 Added copyrights to gameServer directory
Gianfranco Costamagna <costamagnagianfranco@yahoo.it>
parents: 10212
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: 10212
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: 10212
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: 10212
diff changeset
    17
 \-}
8dcea9087d75 Added copyrights to gameServer directory
Gianfranco Costamagna <costamagnagianfranco@yahoo.it>
parents: 10212
diff changeset
    18
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
    19
{-# LANGUAGE OverloadedStrings #-}
1804
4e78ad846fb6 New game server:
unc0rr
parents:
diff changeset
    20
module HWProtoCore where
4e78ad846fb6 New game server:
unc0rr
parents:
diff changeset
    21
4612
e82758d6f924 - Reactivate pings timer, reimplement PING handler
unc0rr
parents: 4337
diff changeset
    22
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
    23
import Data.Maybe
4612
e82758d6f924 - Reactivate pings timer, reimplement PING handler
unc0rr
parents: 4337
diff changeset
    24
import qualified Data.ByteString.Char8 as B
15905
bf92592915c6 Add direct message server command (/msg <nick_name>|<[nick name]> <message>)
S.D.
parents: 14402
diff changeset
    25
import Text.Regex.TDFA
1804
4e78ad846fb6 New game server:
unc0rr
parents:
diff changeset
    26
--------------------------------------
4e78ad846fb6 New game server:
unc0rr
parents:
diff changeset
    27
import CoreTypes
4e78ad846fb6 New game server:
unc0rr
parents:
diff changeset
    28
import HWProtoNEState
4e78ad846fb6 New game server:
unc0rr
parents:
diff changeset
    29
import HWProtoLobbyState
4e78ad846fb6 New game server:
unc0rr
parents:
diff changeset
    30
import HWProtoInRoomState
8479
8d71109b04d2 Some work on loading replay and interaction with checker
unc0rr
parents: 8478
diff changeset
    31
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
    32
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
    33
import RoomsAndClients
4612
e82758d6f924 - Reactivate pings timer, reimplement PING handler
unc0rr
parents: 4337
diff changeset
    34
import Utils
13696
d732ca5dcab9 GameServer: Refactor fake nick names into Consts
Wuzzy <Wuzzy2@mail.ru>
parents: 13694
diff changeset
    35
import Consts
1804
4e78ad846fb6 New game server:
unc0rr
parents:
diff changeset
    36
13866
1a1fb597da8f gameServer: Add user warning if got chat command not suitable for current state (lobby/room); fix protocol errors
Wuzzy <Wuzzy2@mail.ru>
parents: 13854
diff changeset
    37
handleCmd, handleCmd_loggedin, handleCmd_lobbyOnly, handleCmd_roomOnly :: CmdHandler
1804
4e78ad846fb6 New game server:
unc0rr
parents:
diff changeset
    38
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
    39
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
    40
handleCmd ["PING"] = answerClient ["PONG"]
1804
4e78ad846fb6 New game server:
unc0rr
parents:
diff changeset
    41
4e78ad846fb6 New game server:
unc0rr
parents:
diff changeset
    42
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
    43
handleCmd ("QUIT" : xs) = return [ByeClient msg]
2867
9be6693c78cb - Unbreak support for client versions prior to 0.9.13-dev
unc0rr
parents: 2706
diff changeset
    44
    where
13867
d8e606cf8ff5 Simplify /quit chat command
Wuzzy <Wuzzy2@mail.ru>
parents: 13866
diff changeset
    45
        -- "bye" is a special string (do not translate!) when the user quits manually,
d8e606cf8ff5 Simplify /quit chat command
Wuzzy <Wuzzy2@mail.ru>
parents: 13866
diff changeset
    46
        -- otherwise there will be an additional server message
d8e606cf8ff5 Simplify /quit chat command
Wuzzy <Wuzzy2@mail.ru>
parents: 13866
diff changeset
    47
        msg = if not $ null xs then (head xs) else "bye"
1804
4e78ad846fb6 New game server:
unc0rr
parents:
diff changeset
    48
4568
f85243bf890e Ok. This should pull 0.9.14.1 server into default
nemo
parents: 4337
diff changeset
    49
4612
e82758d6f924 - Reactivate pings timer, reimplement PING handler
unc0rr
parents: 4337
diff changeset
    50
handleCmd ["PONG"] = do
e82758d6f924 - Reactivate pings timer, reimplement PING handler
unc0rr
parents: 4337
diff changeset
    51
    cl <- thisClient
e82758d6f924 - Reactivate pings timer, reimplement PING handler
unc0rr
parents: 4337
diff changeset
    52
    if pingsQueue cl == 0 then
8897
d6c310c65c91 - Revert server workaround over desync from r98e2dbdda8c0
unc0rr
parents: 8547
diff changeset
    53
        return [ProtocolError "Protocol violation"]
4612
e82758d6f924 - Reactivate pings timer, reimplement PING handler
unc0rr
parents: 4337
diff changeset
    54
        else
e82758d6f924 - Reactivate pings timer, reimplement PING handler
unc0rr
parents: 4337
diff changeset
    55
        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
    56
11054
6e575b29881c Check for CMD message a bit further down the control flow
unc0rr
parents: 11046
diff changeset
    57
handleCmd cmd = do
6e575b29881c Check for CMD message a bit further down the control flow
unc0rr
parents: 11046
diff changeset
    58
    (ci, irnc) <- ask
6e575b29881c Check for CMD message a bit further down the control flow
unc0rr
parents: 11046
diff changeset
    59
    let cl = irnc `client` ci
6e575b29881c Check for CMD message a bit further down the control flow
unc0rr
parents: 11046
diff changeset
    60
    if logonPassed cl then
6e575b29881c Check for CMD message a bit further down the control flow
unc0rr
parents: 11046
diff changeset
    61
        if isChecker cl then
6e575b29881c Check for CMD message a bit further down the control flow
unc0rr
parents: 11046
diff changeset
    62
            handleCmd_checker cmd
6e575b29881c Check for CMD message a bit further down the control flow
unc0rr
parents: 11046
diff changeset
    63
            else
6e575b29881c Check for CMD message a bit further down the control flow
unc0rr
parents: 11046
diff changeset
    64
            handleCmd_loggedin cmd
6e575b29881c Check for CMD message a bit further down the control flow
unc0rr
parents: 11046
diff changeset
    65
        else
6e575b29881c Check for CMD message a bit further down the control flow
unc0rr
parents: 11046
diff changeset
    66
        handleCmd_NotEntered cmd
6e575b29881c Check for CMD message a bit further down the control flow
unc0rr
parents: 11046
diff changeset
    67
13866
1a1fb597da8f gameServer: Add user warning if got chat command not suitable for current state (lobby/room); fix protocol errors
Wuzzy <Wuzzy2@mail.ru>
parents: 13854
diff changeset
    68
handleCmd_lobbyOnly cmd = do
1a1fb597da8f gameServer: Add user warning if got chat command not suitable for current state (lobby/room); fix protocol errors
Wuzzy <Wuzzy2@mail.ru>
parents: 13854
diff changeset
    69
    (ci, rnc) <- ask
1a1fb597da8f gameServer: Add user warning if got chat command not suitable for current state (lobby/room); fix protocol errors
Wuzzy <Wuzzy2@mail.ru>
parents: 13854
diff changeset
    70
    if (clientRoom rnc ci) == lobbyId then
1a1fb597da8f gameServer: Add user warning if got chat command not suitable for current state (lobby/room); fix protocol errors
Wuzzy <Wuzzy2@mail.ru>
parents: 13854
diff changeset
    71
        handleCmd cmd
1a1fb597da8f gameServer: Add user warning if got chat command not suitable for current state (lobby/room); fix protocol errors
Wuzzy <Wuzzy2@mail.ru>
parents: 13854
diff changeset
    72
    else
1a1fb597da8f gameServer: Add user warning if got chat command not suitable for current state (lobby/room); fix protocol errors
Wuzzy <Wuzzy2@mail.ru>
parents: 13854
diff changeset
    73
        return [Warning $ loc "This command is only available in the lobby."]
1a1fb597da8f gameServer: Add user warning if got chat command not suitable for current state (lobby/room); fix protocol errors
Wuzzy <Wuzzy2@mail.ru>
parents: 13854
diff changeset
    74
1a1fb597da8f gameServer: Add user warning if got chat command not suitable for current state (lobby/room); fix protocol errors
Wuzzy <Wuzzy2@mail.ru>
parents: 13854
diff changeset
    75
handleCmd_roomOnly cmd = do
1a1fb597da8f gameServer: Add user warning if got chat command not suitable for current state (lobby/room); fix protocol errors
Wuzzy <Wuzzy2@mail.ru>
parents: 13854
diff changeset
    76
    (ci, rnc) <- ask
1a1fb597da8f gameServer: Add user warning if got chat command not suitable for current state (lobby/room); fix protocol errors
Wuzzy <Wuzzy2@mail.ru>
parents: 13854
diff changeset
    77
    if (clientRoom rnc ci) == lobbyId then
1a1fb597da8f gameServer: Add user warning if got chat command not suitable for current state (lobby/room); fix protocol errors
Wuzzy <Wuzzy2@mail.ru>
parents: 13854
diff changeset
    78
        return [Warning $ loc "This command is only available in rooms."]
1a1fb597da8f gameServer: Add user warning if got chat command not suitable for current state (lobby/room); fix protocol errors
Wuzzy <Wuzzy2@mail.ru>
parents: 13854
diff changeset
    79
    else
1a1fb597da8f gameServer: Add user warning if got chat command not suitable for current state (lobby/room); fix protocol errors
Wuzzy <Wuzzy2@mail.ru>
parents: 13854
diff changeset
    80
        handleCmd cmd
1a1fb597da8f gameServer: Add user warning if got chat command not suitable for current state (lobby/room); fix protocol errors
Wuzzy <Wuzzy2@mail.ru>
parents: 13854
diff changeset
    81
1a1fb597da8f gameServer: Add user warning if got chat command not suitable for current state (lobby/room); fix protocol errors
Wuzzy <Wuzzy2@mail.ru>
parents: 13854
diff changeset
    82
-- Chat command handling
13850
28a86816dc01 gameServer: Handle empty chat command (partially)
Wuzzy <Wuzzy2@mail.ru>
parents: 13848
diff changeset
    83
unknownCmdWarningText :: B.ByteString
28a86816dc01 gameServer: Handle empty chat command (partially)
Wuzzy <Wuzzy2@mail.ru>
parents: 13848
diff changeset
    84
unknownCmdWarningText = loc "Unknown command or invalid parameters. Say '/help' in chat for a list of commands."
28a86816dc01 gameServer: Handle empty chat command (partially)
Wuzzy <Wuzzy2@mail.ru>
parents: 13848
diff changeset
    85
28a86816dc01 gameServer: Handle empty chat command (partially)
Wuzzy <Wuzzy2@mail.ru>
parents: 13848
diff changeset
    86
handleCmd_loggedin ["CMD"] = return [Warning unknownCmdWarningText]
11054
6e575b29881c Check for CMD message a bit further down the control flow
unc0rr
parents: 11046
diff changeset
    87
6e575b29881c Check for CMD message a bit further down the control flow
unc0rr
parents: 11046
diff changeset
    88
handleCmd_loggedin ["CMD", parameters] = uncurry h $ extractParameters parameters
8396
5123eac2f9d6 - Pass unknown chat commands to server
unc0rr
parents: 7766
diff changeset
    89
    where
13866
1a1fb597da8f gameServer: Add user warning if got chat command not suitable for current state (lobby/room); fix protocol errors
Wuzzy <Wuzzy2@mail.ru>
parents: 13854
diff changeset
    90
        -- room-only commands
1a1fb597da8f gameServer: Add user warning if got chat command not suitable for current state (lobby/room); fix protocol errors
Wuzzy <Wuzzy2@mail.ru>
parents: 13854
diff changeset
    91
        h "DELEGATE" n | not $ B.null n = handleCmd_roomOnly ["DELEGATE", n]
1a1fb597da8f gameServer: Add user warning if got chat command not suitable for current state (lobby/room); fix protocol errors
Wuzzy <Wuzzy2@mail.ru>
parents: 13854
diff changeset
    92
        h "SAVEROOM" n | not $ B.null n = handleCmd_roomOnly ["SAVEROOM", n]
1a1fb597da8f gameServer: Add user warning if got chat command not suitable for current state (lobby/room); fix protocol errors
Wuzzy <Wuzzy2@mail.ru>
parents: 13854
diff changeset
    93
        h "LOADROOM" n | not $ B.null n = handleCmd_roomOnly ["LOADROOM", n]
1a1fb597da8f gameServer: Add user warning if got chat command not suitable for current state (lobby/room); fix protocol errors
Wuzzy <Wuzzy2@mail.ru>
parents: 13854
diff changeset
    94
        h "SAVE" n | not $ B.null n = let (sn, ln) = B.break (== ' ') n in if B.null ln then return [Warning unknownCmdWarningText] else handleCmd_roomOnly ["SAVE", sn, B.tail ln]
1a1fb597da8f gameServer: Add user warning if got chat command not suitable for current state (lobby/room); fix protocol errors
Wuzzy <Wuzzy2@mail.ru>
parents: 13854
diff changeset
    95
        h "DELETE" n | not $ B.null n = handleCmd_roomOnly ["DELETE", n]
1a1fb597da8f gameServer: Add user warning if got chat command not suitable for current state (lobby/room); fix protocol errors
Wuzzy <Wuzzy2@mail.ru>
parents: 13854
diff changeset
    96
        h "FIX" _ = handleCmd_roomOnly ["FIX"]
1a1fb597da8f gameServer: Add user warning if got chat command not suitable for current state (lobby/room); fix protocol errors
Wuzzy <Wuzzy2@mail.ru>
parents: 13854
diff changeset
    97
        h "UNFIX" _ = handleCmd_roomOnly ["UNFIX"]
1a1fb597da8f gameServer: Add user warning if got chat command not suitable for current state (lobby/room); fix protocol errors
Wuzzy <Wuzzy2@mail.ru>
parents: 13854
diff changeset
    98
        h "GREETING" msg = handleCmd_roomOnly ["GREETING", msg]
1a1fb597da8f gameServer: Add user warning if got chat command not suitable for current state (lobby/room); fix protocol errors
Wuzzy <Wuzzy2@mail.ru>
parents: 13854
diff changeset
    99
        h "CALLVOTE" msg | B.null msg = handleCmd_roomOnly ["CALLVOTE"]
1a1fb597da8f gameServer: Add user warning if got chat command not suitable for current state (lobby/room); fix protocol errors
Wuzzy <Wuzzy2@mail.ru>
parents: 13854
diff changeset
   100
                         | otherwise = let (c, p) = extractParameters msg in
1a1fb597da8f gameServer: Add user warning if got chat command not suitable for current state (lobby/room); fix protocol errors
Wuzzy <Wuzzy2@mail.ru>
parents: 13854
diff changeset
   101
                                           if B.null p then handleCmd_roomOnly ["CALLVOTE", c] else handleCmd_roomOnly ["CALLVOTE", c, p]
1a1fb597da8f gameServer: Add user warning if got chat command not suitable for current state (lobby/room); fix protocol errors
Wuzzy <Wuzzy2@mail.ru>
parents: 13854
diff changeset
   102
        h "VOTE" msg | not $ B.null msg = handleCmd_roomOnly ["VOTE", upperCase msg]
1a1fb597da8f gameServer: Add user warning if got chat command not suitable for current state (lobby/room); fix protocol errors
Wuzzy <Wuzzy2@mail.ru>
parents: 13854
diff changeset
   103
                     | otherwise = handleCmd_roomOnly ["VOTE", ""]
1a1fb597da8f gameServer: Add user warning if got chat command not suitable for current state (lobby/room); fix protocol errors
Wuzzy <Wuzzy2@mail.ru>
parents: 13854
diff changeset
   104
        h "FORCE" msg | not $ B.null msg = handleCmd_roomOnly ["VOTE", upperCase msg, "FORCE"]
1a1fb597da8f gameServer: Add user warning if got chat command not suitable for current state (lobby/room); fix protocol errors
Wuzzy <Wuzzy2@mail.ru>
parents: 13854
diff changeset
   105
                      | otherwise = handleCmd_roomOnly ["VOTE", "", "FORCE"]
1a1fb597da8f gameServer: Add user warning if got chat command not suitable for current state (lobby/room); fix protocol errors
Wuzzy <Wuzzy2@mail.ru>
parents: 13854
diff changeset
   106
        h "MAXTEAMS" n | not $ B.null n = handleCmd_roomOnly ["MAXTEAMS", n]
14139
589a752c01ca GameServer: Print syntax help if calling /maxteams without argument
Wuzzy <Wuzzy2@mail.ru>
parents: 13867
diff changeset
   107
                       | otherwise = handleCmd_roomOnly ["MAXTEAMS"]
13866
1a1fb597da8f gameServer: Add user warning if got chat command not suitable for current state (lobby/room); fix protocol errors
Wuzzy <Wuzzy2@mail.ru>
parents: 13854
diff changeset
   108
1a1fb597da8f gameServer: Add user warning if got chat command not suitable for current state (lobby/room); fix protocol errors
Wuzzy <Wuzzy2@mail.ru>
parents: 13854
diff changeset
   109
        -- lobby-only commands
1a1fb597da8f gameServer: Add user warning if got chat command not suitable for current state (lobby/room); fix protocol errors
Wuzzy <Wuzzy2@mail.ru>
parents: 13854
diff changeset
   110
        h "STATS" _ = handleCmd_lobbyOnly ["STATS"]
14402
32e8c81ca35c Add reminder to call /restart_server with "yes"
Wuzzy <Wuzzy2@mail.ru>
parents: 14401
diff changeset
   111
        h "RESTART_SERVER" p = handleCmd_lobbyOnly ["RESTART_SERVER", upperCase p]
13866
1a1fb597da8f gameServer: Add user warning if got chat command not suitable for current state (lobby/room); fix protocol errors
Wuzzy <Wuzzy2@mail.ru>
parents: 13854
diff changeset
   112
1a1fb597da8f gameServer: Add user warning if got chat command not suitable for current state (lobby/room); fix protocol errors
Wuzzy <Wuzzy2@mail.ru>
parents: 13854
diff changeset
   113
        -- room and lobby commands
13867
d8e606cf8ff5 Simplify /quit chat command
Wuzzy <Wuzzy2@mail.ru>
parents: 13866
diff changeset
   114
        h "QUIT" _ = handleCmd ["QUIT"]
9105
18ebb59c89fe Proper parameters handling of chat commands
unc0rr
parents: 9061
diff changeset
   115
        h "RND" p = handleCmd ("RND" : B.words p)
11467
f2c36df8c7b1 Allow server admins to join passworded/restricted rooms when it is really needed
unc0rr
parents: 11466
diff changeset
   116
        h "GLOBAL" p = serverAdminOnly $ do
8547
6898be8aa261 Global notice with /global command. Can now warn users when doing server restart.
unc0rr
parents: 8519
diff changeset
   117
            rnc <- liftM snd ask
6898be8aa261 Global notice with /global command. Can now warn users when doing server restart.
unc0rr
parents: 8519
diff changeset
   118
            let chans = map (sendChan . client rnc) $ allClients rnc
13696
d732ca5dcab9 GameServer: Refactor fake nick names into Consts
Wuzzy <Wuzzy2@mail.ru>
parents: 13694
diff changeset
   119
            return [AnswerClients chans ["CHAT", nickGlobal, p]]
9448
04e0acfa7c2c /watch works in testing environment
unc0rr
parents: 9446
diff changeset
   120
        h "WATCH" f = return [QueryReplay f]
10882
ed7717f659ae - Fix ping timeouts after incorrect "/vote" commands (protocol violation)
unc0rr
parents: 10881
diff changeset
   121
        h "INFO" n | not $ B.null n = handleCmd ["INFO", n]
15905
bf92592915c6 Add direct message server command (/msg <nick_name>|<[nick name]> <message>)
S.D.
parents: 14402
diff changeset
   122
        h "ALLOW_MSG" state = handleCmd ["ALLOW_MSG", state]
bf92592915c6 Add direct message server command (/msg <nick_name>|<[nick name]> <message>)
S.D.
parents: 14402
diff changeset
   123
        h "MSG" n = handleCmd ["MSG", n]
13514
da59012fbd7a Add /help command for lobby and rooms too
Wuzzy <Wuzzy2@mail.ru>
parents: 11974
diff changeset
   124
        h "HELP" _ = handleCmd ["HELP"]
11467
f2c36df8c7b1 Allow server admins to join passworded/restricted rooms when it is really needed
unc0rr
parents: 11466
diff changeset
   125
        h "REGISTERED_ONLY" _ = serverAdminOnly $ do
14401
8ad85859dd3f /registered_only now tells in chat whether the state is on or off
Wuzzy <Wuzzy2@mail.ru>
parents: 14139
diff changeset
   126
            rnc <- liftM snd ask
8ad85859dd3f /registered_only now tells in chat whether the state is on or off
Wuzzy <Wuzzy2@mail.ru>
parents: 14139
diff changeset
   127
            let chans = map (sendChan . client rnc) $ allClients rnc
11467
f2c36df8c7b1 Allow server admins to join passworded/restricted rooms when it is really needed
unc0rr
parents: 11466
diff changeset
   128
            return
11466
4b5c7a5c49fd Defer kicking to the time when everything is in consistent state
unc0rr
parents: 11465
diff changeset
   129
                [ModifyServerInfo(\s -> s{isRegisteredUsersOnly = not $ isRegisteredUsersOnly s})
14401
8ad85859dd3f /registered_only now tells in chat whether the state is on or off
Wuzzy <Wuzzy2@mail.ru>
parents: 14139
diff changeset
   130
                , ShowRegisteredOnlyState chans
11465
0ae2e4c13bd1 Allow toggling registration requirement on live server
unc0rr
parents: 11054
diff changeset
   131
                ]
13694
91fe09213abc Tweak response messages to /super_power and /registered_only
Wuzzy <Wuzzy2@mail.ru>
parents: 13693
diff changeset
   132
        h "SUPER_POWER" _ = serverAdminOnly $ do
91fe09213abc Tweak response messages to /super_power and /registered_only
Wuzzy <Wuzzy2@mail.ru>
parents: 13693
diff changeset
   133
            cl <- thisClient
91fe09213abc Tweak response messages to /super_power and /registered_only
Wuzzy <Wuzzy2@mail.ru>
parents: 13693
diff changeset
   134
            return
91fe09213abc Tweak response messages to /super_power and /registered_only
Wuzzy <Wuzzy2@mail.ru>
parents: 13693
diff changeset
   135
                [ModifyClient (\c -> c{hasSuperPower = True})
13696
d732ca5dcab9 GameServer: Refactor fake nick names into Consts
Wuzzy <Wuzzy2@mail.ru>
parents: 13694
diff changeset
   136
                , AnswerClients [sendChan cl] ["CHAT", nickServer, loc "Super power activated."]
13694
91fe09213abc Tweak response messages to /super_power and /registered_only
Wuzzy <Wuzzy2@mail.ru>
parents: 13693
diff changeset
   137
                ]
13850
28a86816dc01 gameServer: Handle empty chat command (partially)
Wuzzy <Wuzzy2@mail.ru>
parents: 13848
diff changeset
   138
        h _ _ = return [Warning unknownCmdWarningText]
13516
60bcc20e6ab0 Improve some replies for chat commands on server
Wuzzy <Wuzzy2@mail.ru>
parents: 13514
diff changeset
   139
8396
5123eac2f9d6 - Pass unknown chat commands to server
unc0rr
parents: 7766
diff changeset
   140
10039
58cf89284115 Halfplement voting
unc0rr
parents: 9787
diff changeset
   141
        extractParameters p = let (a, b) = B.break (== ' ') p in (upperCase a, B.dropWhile (== ' ') b)
58cf89284115 Halfplement voting
unc0rr
parents: 9787
diff changeset
   142
15905
bf92592915c6 Add direct message server command (/msg <nick_name>|<[nick name]> <message>)
S.D.
parents: 14402
diff changeset
   143
handleCmd_loggedin ["MSG", nickMsg] = do
bf92592915c6 Add direct message server command (/msg <nick_name>|<[nick name]> <message>)
S.D.
parents: 14402
diff changeset
   144
    thisCl <- thisClient
bf92592915c6 Add direct message server command (/msg <nick_name>|<[nick name]> <message>)
S.D.
parents: 14402
diff changeset
   145
    thisNick <- clientNick
bf92592915c6 Add direct message server command (/msg <nick_name>|<[nick name]> <message>)
S.D.
parents: 14402
diff changeset
   146
    clChans <- thisClientChans
bf92592915c6 Add direct message server command (/msg <nick_name>|<[nick name]> <message>)
S.D.
parents: 14402
diff changeset
   147
    let addEcho nick msg a = AnswerClients clChans ["CHAT", thisNick, B.concat ["/msg [", nick, "] ", msg]] : a
bf92592915c6 Add direct message server command (/msg <nick_name>|<[nick name]> <message>)
S.D.
parents: 14402
diff changeset
   148
    let sendingMsgAllowed clientInfo = case allowMsgState clientInfo of
bf92592915c6 Add direct message server command (/msg <nick_name>|<[nick name]> <message>)
S.D.
parents: 14402
diff changeset
   149
          AllowAll -> True
bf92592915c6 Add direct message server command (/msg <nick_name>|<[nick name]> <message>)
S.D.
parents: 14402
diff changeset
   150
          AllowRegistered -> isRegistered thisCl
bf92592915c6 Add direct message server command (/msg <nick_name>|<[nick name]> <message>)
S.D.
parents: 14402
diff changeset
   151
          AllowNone -> False
bf92592915c6 Add direct message server command (/msg <nick_name>|<[nick name]> <message>)
S.D.
parents: 14402
diff changeset
   152
    let sendNickMsg nick msg = do
bf92592915c6 Add direct message server command (/msg <nick_name>|<[nick name]> <message>)
S.D.
parents: 14402
diff changeset
   153
          (_, rnc) <- ask
bf92592915c6 Add direct message server command (/msg <nick_name>|<[nick name]> <message>)
S.D.
parents: 14402
diff changeset
   154
          maybeClientId <- clientByNick nick
bf92592915c6 Add direct message server command (/msg <nick_name>|<[nick name]> <message>)
S.D.
parents: 14402
diff changeset
   155
          case maybeClientId of
bf92592915c6 Add direct message server command (/msg <nick_name>|<[nick name]> <message>)
S.D.
parents: 14402
diff changeset
   156
              Just cl -> let ci = client rnc cl in
bf92592915c6 Add direct message server command (/msg <nick_name>|<[nick name]> <message>)
S.D.
parents: 14402
diff changeset
   157
                  if sendingMsgAllowed ci  then
bf92592915c6 Add direct message server command (/msg <nick_name>|<[nick name]> <message>)
S.D.
parents: 14402
diff changeset
   158
                      return [AnswerClients [sendChan ci]
bf92592915c6 Add direct message server command (/msg <nick_name>|<[nick name]> <message>)
S.D.
parents: 14402
diff changeset
   159
                              ["CHAT", thisNick, B.concat ["[direct] ", msg]]]
bf92592915c6 Add direct message server command (/msg <nick_name>|<[nick name]> <message>)
S.D.
parents: 14402
diff changeset
   160
                  else
bf92592915c6 Add direct message server command (/msg <nick_name>|<[nick name]> <message>)
S.D.
parents: 14402
diff changeset
   161
                      return [Warning $ loc "Player is not allowing direct messages."]
bf92592915c6 Add direct message server command (/msg <nick_name>|<[nick name]> <message>)
S.D.
parents: 14402
diff changeset
   162
              Nothing -> return [Warning $ loc "Player is not online."]
bf92592915c6 Add direct message server command (/msg <nick_name>|<[nick name]> <message>)
S.D.
parents: 14402
diff changeset
   163
bf92592915c6 Add direct message server command (/msg <nick_name>|<[nick name]> <message>)
S.D.
parents: 14402
diff changeset
   164
    case nickMsg =~ ("^[[:space:]]*\\[([^]\\[]*)\\][[:space:]]*(.*)$" :: B.ByteString) of
bf92592915c6 Add direct message server command (/msg <nick_name>|<[nick name]> <message>)
S.D.
parents: 14402
diff changeset
   165
        [[_, "", msg]] -> return [Warning $ loc "Invalid /msg command."]
bf92592915c6 Add direct message server command (/msg <nick_name>|<[nick name]> <message>)
S.D.
parents: 14402
diff changeset
   166
        [[_, nick, msg]] -> addEcho (B.strip nick) msg <$> sendNickMsg (B.strip nick) msg
bf92592915c6 Add direct message server command (/msg <nick_name>|<[nick name]> <message>)
S.D.
parents: 14402
diff changeset
   167
        [] -> case nickMsg =~ ("^[[:space:]]*([^[:space:]]+)[[:space:]]*(.*)$" :: B.ByteString) of
bf92592915c6 Add direct message server command (/msg <nick_name>|<[nick name]> <message>)
S.D.
parents: 14402
diff changeset
   168
            [[_, nick, msg]] -> addEcho nick msg <$> sendNickMsg nick msg
bf92592915c6 Add direct message server command (/msg <nick_name>|<[nick name]> <message>)
S.D.
parents: 14402
diff changeset
   169
            [] -> return [Warning $ loc "Invalid /msg command."]
bf92592915c6 Add direct message server command (/msg <nick_name>|<[nick name]> <message>)
S.D.
parents: 14402
diff changeset
   170
bf92592915c6 Add direct message server command (/msg <nick_name>|<[nick name]> <message>)
S.D.
parents: 14402
diff changeset
   171
bf92592915c6 Add direct message server command (/msg <nick_name>|<[nick name]> <message>)
S.D.
parents: 14402
diff changeset
   172
handleCmd_loggedin ["ALLOW_MSG", state] = do
bf92592915c6 Add direct message server command (/msg <nick_name>|<[nick name]> <message>)
S.D.
parents: 14402
diff changeset
   173
    cl <- thisClient
bf92592915c6 Add direct message server command (/msg <nick_name>|<[nick name]> <message>)
S.D.
parents: 14402
diff changeset
   174
    let statusMsg state = B.pack $ "Direct messages allowed: " ++ stateToStr state
bf92592915c6 Add direct message server command (/msg <nick_name>|<[nick name]> <message>)
S.D.
parents: 14402
diff changeset
   175
    let changeIgnoreState newState = [
bf92592915c6 Add direct message server command (/msg <nick_name>|<[nick name]> <message>)
S.D.
parents: 14402
diff changeset
   176
            ModifyClient (\c -> c{allowMsgState = newState}),
bf92592915c6 Add direct message server command (/msg <nick_name>|<[nick name]> <message>)
S.D.
parents: 14402
diff changeset
   177
            AnswerClients [sendChan cl] ["CHAT", nickServer, loc $ statusMsg newState]]
bf92592915c6 Add direct message server command (/msg <nick_name>|<[nick name]> <message>)
S.D.
parents: 14402
diff changeset
   178
    let maybeNewState = stateFromStr state
bf92592915c6 Add direct message server command (/msg <nick_name>|<[nick name]> <message>)
S.D.
parents: 14402
diff changeset
   179
    return $ maybe
bf92592915c6 Add direct message server command (/msg <nick_name>|<[nick name]> <message>)
S.D.
parents: 14402
diff changeset
   180
        [Warning unknownCmdWarningText] changeIgnoreState maybeNewState
bf92592915c6 Add direct message server command (/msg <nick_name>|<[nick name]> <message>)
S.D.
parents: 14402
diff changeset
   181
    where
bf92592915c6 Add direct message server command (/msg <nick_name>|<[nick name]> <message>)
S.D.
parents: 14402
diff changeset
   182
        stateFromStr str = case B.strip str of
bf92592915c6 Add direct message server command (/msg <nick_name>|<[nick name]> <message>)
S.D.
parents: 14402
diff changeset
   183
            "all" -> Just AllowAll
bf92592915c6 Add direct message server command (/msg <nick_name>|<[nick name]> <message>)
S.D.
parents: 14402
diff changeset
   184
            "registered" -> Just AllowRegistered
bf92592915c6 Add direct message server command (/msg <nick_name>|<[nick name]> <message>)
S.D.
parents: 14402
diff changeset
   185
            "none" -> Just AllowNone
bf92592915c6 Add direct message server command (/msg <nick_name>|<[nick name]> <message>)
S.D.
parents: 14402
diff changeset
   186
            _ -> Nothing
bf92592915c6 Add direct message server command (/msg <nick_name>|<[nick name]> <message>)
S.D.
parents: 14402
diff changeset
   187
        stateToStr state = case state of
bf92592915c6 Add direct message server command (/msg <nick_name>|<[nick name]> <message>)
S.D.
parents: 14402
diff changeset
   188
            AllowAll -> "all"
bf92592915c6 Add direct message server command (/msg <nick_name>|<[nick name]> <message>)
S.D.
parents: 14402
diff changeset
   189
            AllowRegistered -> "registered"
bf92592915c6 Add direct message server command (/msg <nick_name>|<[nick name]> <message>)
S.D.
parents: 14402
diff changeset
   190
            AllowNone -> "none"
bf92592915c6 Add direct message server command (/msg <nick_name>|<[nick name]> <message>)
S.D.
parents: 14402
diff changeset
   191
bf92592915c6 Add direct message server command (/msg <nick_name>|<[nick name]> <message>)
S.D.
parents: 14402
diff changeset
   192
4612
e82758d6f924 - Reactivate pings timer, reimplement PING handler
unc0rr
parents: 4337
diff changeset
   193
handleCmd_loggedin ["INFO", asknick] = do
e82758d6f924 - Reactivate pings timer, reimplement PING handler
unc0rr
parents: 4337
diff changeset
   194
    (_, rnc) <- ask
4614
26661bf28dd5 Reimplement some more protocol commands
unc0rr
parents: 4612
diff changeset
   195
    maybeClientId <- clientByNick asknick
5060
7d0f6e5b1c1c Hide last two octets of IP address from usual users
unc0rr
parents: 5030
diff changeset
   196
    isAdminAsking <- liftM isAdministrator thisClient
4612
e82758d6f924 - Reactivate pings timer, reimplement PING handler
unc0rr
parents: 4337
diff changeset
   197
    let noSuchClient = isNothing maybeClientId
e82758d6f924 - Reactivate pings timer, reimplement PING handler
unc0rr
parents: 4337
diff changeset
   198
    let clientId = fromJust maybeClientId
e82758d6f924 - Reactivate pings timer, reimplement PING handler
unc0rr
parents: 4337
diff changeset
   199
    let cl = rnc `client` fromJust maybeClientId
e82758d6f924 - Reactivate pings timer, reimplement PING handler
unc0rr
parents: 4337
diff changeset
   200
    let roomId = clientRoom rnc clientId
e82758d6f924 - Reactivate pings timer, reimplement PING handler
unc0rr
parents: 4337
diff changeset
   201
    let clRoom = room rnc roomId
9061
38e8787483db '@' for server admin status, '+' for room admins
unc0rr
parents: 9035
diff changeset
   202
    let roomMasterSign = if isMaster cl then "+" else ""
4612
e82758d6f924 - Reactivate pings timer, reimplement PING handler
unc0rr
parents: 4337
diff changeset
   203
    let adminSign = if isAdministrator cl then "@" else ""
13516
60bcc20e6ab0 Improve some replies for chat commands on server
Wuzzy <Wuzzy2@mail.ru>
parents: 13514
diff changeset
   204
    let rInfo = if roomId /= lobbyId then B.concat [adminSign, roomMasterSign, loc "room", " ", name clRoom] else adminSign `B.append` (loc "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
   205
    let roomStatus = if isJust $ gameInfo clRoom then
13516
60bcc20e6ab0 Improve some replies for chat commands on server
Wuzzy <Wuzzy2@mail.ru>
parents: 13514
diff changeset
   206
            if teamsInGame cl > 0 then (loc "(playing)") else (loc "(spectating)")
4612
e82758d6f924 - Reactivate pings timer, reimplement PING handler
unc0rr
parents: 4337
diff changeset
   207
            else
e82758d6f924 - Reactivate pings timer, reimplement PING handler
unc0rr
parents: 4337
diff changeset
   208
            ""
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
   209
    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
   210
    if noSuchClient then
13696
d732ca5dcab9 GameServer: Refactor fake nick names into Consts
Wuzzy <Wuzzy2@mail.ru>
parents: 13694
diff changeset
   211
        answerClient [ "CHAT", nickServer, loc "Player is not online." ]
4612
e82758d6f924 - Reactivate pings timer, reimplement PING handler
unc0rr
parents: 4337
diff changeset
   212
        else
e82758d6f924 - Reactivate pings timer, reimplement PING handler
unc0rr
parents: 4337
diff changeset
   213
        answerClient [
e82758d6f924 - Reactivate pings timer, reimplement PING handler
unc0rr
parents: 4337
diff changeset
   214
            "INFO",
e82758d6f924 - Reactivate pings timer, reimplement PING handler
unc0rr
parents: 4337
diff changeset
   215
            nick cl,
5060
7d0f6e5b1c1c Hide last two octets of IP address from usual users
unc0rr
parents: 5030
diff changeset
   216
            B.concat ["[", hostStr, "]"],
4612
e82758d6f924 - Reactivate pings timer, reimplement PING handler
unc0rr
parents: 4337
diff changeset
   217
            protoNumber2ver $ clientProto cl,
7766
98edc0724a28 Fix most of server warnings
unc0rr
parents: 5996
diff changeset
   218
            B.concat ["[", rInfo, "]", roomStatus]
4612
e82758d6f924 - Reactivate pings timer, reimplement PING handler
unc0rr
parents: 4337
diff changeset
   219
            ]
1862
7f303aa066da Implement kick from server by administrator
unc0rr
parents: 1841
diff changeset
   220
7f303aa066da Implement kick from server by administrator
unc0rr
parents: 1841
diff changeset
   221
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
   222
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
   223
    (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
   224
    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
   225
        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
   226
        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
   227
        handleCmd_inRoom cmd