gameServer/HWProtoCore.hs
author dag10
Sun, 27 Jan 2013 20:17:30 -0500
changeset 8453 06541556df53
parent 8403 fbc6e7602e05
child 8478 d12531f09d59
permissions -rw-r--r--
Reorganized layout and appearance of rooms list page. Creating a new room uses a dialog prompt for the room name, which is preset to whatever your last room name was. Removed dotted rectangle around selected cell in rooms list. Removed bug where gamecfgwidget would be in master mode when joining a game as a slave. Can now join selected room when return is pressed. Can also move room selection while room search box has focus.
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
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
e82758d6f924 - Reactivate pings timer, reimplement PING handler
unc0rr
parents: 4337
diff changeset
    32
        return [ProtocolError "Protocol violation"]
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
8396
5123eac2f9d6 - Pass unknown chat commands to server
unc0rr
parents: 7766
diff changeset
    36
handleCmd ("CMD" : params) =
5123eac2f9d6 - Pass unknown chat commands to server
unc0rr
parents: 7766
diff changeset
    37
    let c = concatMap B.words params in
5123eac2f9d6 - Pass unknown chat commands to server
unc0rr
parents: 7766
diff changeset
    38
        if not $ null c then
5123eac2f9d6 - Pass unknown chat commands to server
unc0rr
parents: 7766
diff changeset
    39
            h $ (upperCase . head $ c) : tail c
5123eac2f9d6 - Pass unknown chat commands to server
unc0rr
parents: 7766
diff changeset
    40
            else
5123eac2f9d6 - Pass unknown chat commands to server
unc0rr
parents: 7766
diff changeset
    41
            return []
5123eac2f9d6 - Pass unknown chat commands to server
unc0rr
parents: 7766
diff changeset
    42
    where
5123eac2f9d6 - Pass unknown chat commands to server
unc0rr
parents: 7766
diff changeset
    43
        h ["DELEGATE", n] = handleCmd ["DELEGATE", n]
8403
fbc6e7602e05 - Allow server admins to use DELEGATE even when not room owner
unc0rr
parents: 8401
diff changeset
    44
        h ["STATS"] = handleCmd ["STATS"]
8396
5123eac2f9d6 - Pass unknown chat commands to server
unc0rr
parents: 7766
diff changeset
    45
        h c = return [Warning . B.concat . L.intersperse " " $ "Unknown cmd" : c]
5123eac2f9d6 - Pass unknown chat commands to server
unc0rr
parents: 7766
diff changeset
    46
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
    47
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
    48
    (ci, irnc) <- 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
    49
    if logonPassed (irnc `client` ci) 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
    50
        handleCmd_loggedin 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
    51
        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
    52
        handleCmd_NotEntered cmd
1862
7f303aa066da Implement kick from server by administrator
unc0rr
parents: 1841
diff changeset
    53
4568
f85243bf890e Ok. This should pull 0.9.14.1 server into default
nemo
parents: 4337
diff changeset
    54
4612
e82758d6f924 - Reactivate pings timer, reimplement PING handler
unc0rr
parents: 4337
diff changeset
    55
handleCmd_loggedin ["INFO", asknick] = do
e82758d6f924 - Reactivate pings timer, reimplement PING handler
unc0rr
parents: 4337
diff changeset
    56
    (_, rnc) <- ask
4614
26661bf28dd5 Reimplement some more protocol commands
unc0rr
parents: 4612
diff changeset
    57
    maybeClientId <- clientByNick asknick
5060
7d0f6e5b1c1c Hide last two octets of IP address from usual users
unc0rr
parents: 5030
diff changeset
    58
    isAdminAsking <- liftM isAdministrator thisClient
4612
e82758d6f924 - Reactivate pings timer, reimplement PING handler
unc0rr
parents: 4337
diff changeset
    59
    let noSuchClient = isNothing maybeClientId
e82758d6f924 - Reactivate pings timer, reimplement PING handler
unc0rr
parents: 4337
diff changeset
    60
    let clientId = fromJust maybeClientId
e82758d6f924 - Reactivate pings timer, reimplement PING handler
unc0rr
parents: 4337
diff changeset
    61
    let cl = rnc `client` fromJust maybeClientId
e82758d6f924 - Reactivate pings timer, reimplement PING handler
unc0rr
parents: 4337
diff changeset
    62
    let roomId = clientRoom rnc clientId
e82758d6f924 - Reactivate pings timer, reimplement PING handler
unc0rr
parents: 4337
diff changeset
    63
    let clRoom = room rnc roomId
e82758d6f924 - Reactivate pings timer, reimplement PING handler
unc0rr
parents: 4337
diff changeset
    64
    let roomMasterSign = if isMaster cl then "@" else ""
e82758d6f924 - Reactivate pings timer, reimplement PING handler
unc0rr
parents: 4337
diff changeset
    65
    let adminSign = if isAdministrator cl then "@" else ""
7766
98edc0724a28 Fix most of server warnings
unc0rr
parents: 5996
diff changeset
    66
    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
    67
    let roomStatus = if isJust $ gameInfo clRoom then
4612
e82758d6f924 - Reactivate pings timer, reimplement PING handler
unc0rr
parents: 4337
diff changeset
    68
            if teamsInGame cl > 0 then "(playing)" else "(spectating)"
e82758d6f924 - Reactivate pings timer, reimplement PING handler
unc0rr
parents: 4337
diff changeset
    69
            else
e82758d6f924 - Reactivate pings timer, reimplement PING handler
unc0rr
parents: 4337
diff changeset
    70
            ""
5060
7d0f6e5b1c1c Hide last two octets of IP address from usual users
unc0rr
parents: 5030
diff changeset
    71
    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
    72
    if noSuchClient then
4612
e82758d6f924 - Reactivate pings timer, reimplement PING handler
unc0rr
parents: 4337
diff changeset
    73
        return []
e82758d6f924 - Reactivate pings timer, reimplement PING handler
unc0rr
parents: 4337
diff changeset
    74
        else
e82758d6f924 - Reactivate pings timer, reimplement PING handler
unc0rr
parents: 4337
diff changeset
    75
        answerClient [
e82758d6f924 - Reactivate pings timer, reimplement PING handler
unc0rr
parents: 4337
diff changeset
    76
            "INFO",
e82758d6f924 - Reactivate pings timer, reimplement PING handler
unc0rr
parents: 4337
diff changeset
    77
            nick cl,
5060
7d0f6e5b1c1c Hide last two octets of IP address from usual users
unc0rr
parents: 5030
diff changeset
    78
            B.concat ["[", hostStr, "]"],
4612
e82758d6f924 - Reactivate pings timer, reimplement PING handler
unc0rr
parents: 4337
diff changeset
    79
            protoNumber2ver $ clientProto cl,
7766
98edc0724a28 Fix most of server warnings
unc0rr
parents: 5996
diff changeset
    80
            B.concat ["[", rInfo, "]", roomStatus]
4612
e82758d6f924 - Reactivate pings timer, reimplement PING handler
unc0rr
parents: 4337
diff changeset
    81
            ]
1862
7f303aa066da Implement kick from server by administrator
unc0rr
parents: 1841
diff changeset
    82
7f303aa066da Implement kick from server by administrator
unc0rr
parents: 1841
diff changeset
    83
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
    84
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
    85
    (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
    86
    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
    87
        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
    88
        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
    89
        handleCmd_inRoom cmd