gameServer/HWProtoCore.hs
author nemo
Thu, 01 Jul 2010 23:41:10 -0400
changeset 3608 c509bbc779e7
parent 3500 af8390d807d6
child 3671 a94d1dc4a8d9
permissions -rw-r--r--
Revert prior attempted optimisation. Gridding the land pays in some situations, but not all. Restricting to an upper bound might help, but overall, seems too fuzzy to be worth it. On one side is increased cost of Add/Delete + extra test on collision check, on the other is skipping the list iteration. Perhaps for large lists.
Ignore whitespace changes - Everywhere: Within whitespace: At end of lines:
3500
af8390d807d6 Use sockets instead of handles, use bytestrings instead of strings
unc0rr
parents: 3458
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
4e78ad846fb6 New game server:
unc0rr
parents:
diff changeset
     4
import qualified Data.IntMap as IntMap
1862
7f303aa066da Implement kick from server by administrator
unc0rr
parents: 1841
diff changeset
     5
import Data.Foldable
7f303aa066da Implement kick from server by administrator
unc0rr
parents: 1841
diff changeset
     6
import Maybe
3435
4e4f88a7bdf2 Some more steps in refactoring
unc0rr
parents: 2961
diff changeset
     7
import Control.Monad.Reader
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 Utils
4e78ad846fb6 New game server:
unc0rr
parents:
diff changeset
    12
import HWProtoNEState
4e78ad846fb6 New game server:
unc0rr
parents:
diff changeset
    13
import HWProtoLobbyState
4e78ad846fb6 New game server:
unc0rr
parents:
diff changeset
    14
import HWProtoInRoomState
3435
4e4f88a7bdf2 Some more steps in refactoring
unc0rr
parents: 2961
diff changeset
    15
import HandlerUtils
4e4f88a7bdf2 Some more steps in refactoring
unc0rr
parents: 2961
diff changeset
    16
import RoomsAndClients
1804
4e78ad846fb6 New game server:
unc0rr
parents:
diff changeset
    17
1862
7f303aa066da Implement kick from server by administrator
unc0rr
parents: 1841
diff changeset
    18
handleCmd, handleCmd_loggedin :: CmdHandler
1804
4e78ad846fb6 New game server:
unc0rr
parents:
diff changeset
    19
3435
4e4f88a7bdf2 Some more steps in refactoring
unc0rr
parents: 2961
diff changeset
    20
4e4f88a7bdf2 Some more steps in refactoring
unc0rr
parents: 2961
diff changeset
    21
handleCmd ["PING"] = answerClient ["PONG"]
1804
4e78ad846fb6 New game server:
unc0rr
parents:
diff changeset
    22
3435
4e4f88a7bdf2 Some more steps in refactoring
unc0rr
parents: 2961
diff changeset
    23
4e4f88a7bdf2 Some more steps in refactoring
unc0rr
parents: 2961
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
9be6693c78cb - Unbreak support for client versions prior to 0.9.13-dev
unc0rr
parents: 2706
diff changeset
    26
        msg = if not $ null xs then head xs else ""
1804
4e78ad846fb6 New game server:
unc0rr
parents:
diff changeset
    27
3435
4e4f88a7bdf2 Some more steps in refactoring
unc0rr
parents: 2961
diff changeset
    28
{-
3458
11cd56019f00 Make some more protocol commands work
unc0rr
parents: 3435
diff changeset
    29
handleCmd ["PONG"] =
2867
9be6693c78cb - Unbreak support for client versions prior to 0.9.13-dev
unc0rr
parents: 2706
diff changeset
    30
    if pingsQueue client == 0 then
9be6693c78cb - Unbreak support for client versions prior to 0.9.13-dev
unc0rr
parents: 2706
diff changeset
    31
        [ProtocolError "Protocol violation"]
9be6693c78cb - Unbreak support for client versions prior to 0.9.13-dev
unc0rr
parents: 2706
diff changeset
    32
    else
9be6693c78cb - Unbreak support for client versions prior to 0.9.13-dev
unc0rr
parents: 2706
diff changeset
    33
        [ModifyClient (\cl -> cl{pingsQueue = pingsQueue cl - 1})]
9be6693c78cb - Unbreak support for client versions prior to 0.9.13-dev
unc0rr
parents: 2706
diff changeset
    34
    where
9be6693c78cb - Unbreak support for client versions prior to 0.9.13-dev
unc0rr
parents: 2706
diff changeset
    35
        client = clients IntMap.! clID
3435
4e4f88a7bdf2 Some more steps in refactoring
unc0rr
parents: 2961
diff changeset
    36
-}
1928
9bf8f4f30d6b - Implement ping timeout
unc0rr
parents: 1879
diff changeset
    37
3435
4e4f88a7bdf2 Some more steps in refactoring
unc0rr
parents: 2961
diff changeset
    38
handleCmd cmd = do
4e4f88a7bdf2 Some more steps in refactoring
unc0rr
parents: 2961
diff changeset
    39
    (ci, irnc) <- ask
4e4f88a7bdf2 Some more steps in refactoring
unc0rr
parents: 2961
diff changeset
    40
    if logonPassed (irnc `client` ci) then
3458
11cd56019f00 Make some more protocol commands work
unc0rr
parents: 3435
diff changeset
    41
        handleCmd_loggedin cmd
3435
4e4f88a7bdf2 Some more steps in refactoring
unc0rr
parents: 2961
diff changeset
    42
        else
3458
11cd56019f00 Make some more protocol commands work
unc0rr
parents: 3435
diff changeset
    43
        handleCmd_NotEntered cmd
1862
7f303aa066da Implement kick from server by administrator
unc0rr
parents: 1841
diff changeset
    44
3435
4e4f88a7bdf2 Some more steps in refactoring
unc0rr
parents: 2961
diff changeset
    45
{-
1862
7f303aa066da Implement kick from server by administrator
unc0rr
parents: 1841
diff changeset
    46
handleCmd_loggedin clID clients rooms ["INFO", asknick] =
2867
9be6693c78cb - Unbreak support for client versions prior to 0.9.13-dev
unc0rr
parents: 2706
diff changeset
    47
    if noSuchClient then
9be6693c78cb - Unbreak support for client versions prior to 0.9.13-dev
unc0rr
parents: 2706
diff changeset
    48
        []
9be6693c78cb - Unbreak support for client versions prior to 0.9.13-dev
unc0rr
parents: 2706
diff changeset
    49
    else
9be6693c78cb - Unbreak support for client versions prior to 0.9.13-dev
unc0rr
parents: 2706
diff changeset
    50
        [AnswerThisClient
9be6693c78cb - Unbreak support for client versions prior to 0.9.13-dev
unc0rr
parents: 2706
diff changeset
    51
            ["INFO",
9be6693c78cb - Unbreak support for client versions prior to 0.9.13-dev
unc0rr
parents: 2706
diff changeset
    52
            nick client,
9be6693c78cb - Unbreak support for client versions prior to 0.9.13-dev
unc0rr
parents: 2706
diff changeset
    53
            "[" ++ host client ++ "]",
9be6693c78cb - Unbreak support for client versions prior to 0.9.13-dev
unc0rr
parents: 2706
diff changeset
    54
            protoNumber2ver $ clientProto client,
9be6693c78cb - Unbreak support for client versions prior to 0.9.13-dev
unc0rr
parents: 2706
diff changeset
    55
            "[" ++ roomInfo ++ "]" ++ roomStatus]]
9be6693c78cb - Unbreak support for client versions prior to 0.9.13-dev
unc0rr
parents: 2706
diff changeset
    56
    where
9be6693c78cb - Unbreak support for client versions prior to 0.9.13-dev
unc0rr
parents: 2706
diff changeset
    57
        maybeClient = find (\cl -> asknick == nick cl) clients
9be6693c78cb - Unbreak support for client versions prior to 0.9.13-dev
unc0rr
parents: 2706
diff changeset
    58
        noSuchClient = isNothing maybeClient
9be6693c78cb - Unbreak support for client versions prior to 0.9.13-dev
unc0rr
parents: 2706
diff changeset
    59
        client = fromJust maybeClient
9be6693c78cb - Unbreak support for client versions prior to 0.9.13-dev
unc0rr
parents: 2706
diff changeset
    60
        room = rooms IntMap.! roomID client
9be6693c78cb - Unbreak support for client versions prior to 0.9.13-dev
unc0rr
parents: 2706
diff changeset
    61
        roomInfo = if roomID client /= 0 then roomMasterSign ++ "room " ++ (name room) else adminSign ++ "lobby"
9be6693c78cb - Unbreak support for client versions prior to 0.9.13-dev
unc0rr
parents: 2706
diff changeset
    62
        roomMasterSign = if isMaster client then "@" else ""
9be6693c78cb - Unbreak support for client versions prior to 0.9.13-dev
unc0rr
parents: 2706
diff changeset
    63
        adminSign = if isAdministrator client then "@" else ""
9be6693c78cb - Unbreak support for client versions prior to 0.9.13-dev
unc0rr
parents: 2706
diff changeset
    64
        roomStatus =
9be6693c78cb - Unbreak support for client versions prior to 0.9.13-dev
unc0rr
parents: 2706
diff changeset
    65
            if gameinprogress room
9be6693c78cb - Unbreak support for client versions prior to 0.9.13-dev
unc0rr
parents: 2706
diff changeset
    66
            then if teamsInGame client > 0 then "(playing)" else "(spectating)"
9be6693c78cb - Unbreak support for client versions prior to 0.9.13-dev
unc0rr
parents: 2706
diff changeset
    67
            else ""
1862
7f303aa066da Implement kick from server by administrator
unc0rr
parents: 1841
diff changeset
    68
3435
4e4f88a7bdf2 Some more steps in refactoring
unc0rr
parents: 2961
diff changeset
    69
-}
1862
7f303aa066da Implement kick from server by administrator
unc0rr
parents: 1841
diff changeset
    70
3435
4e4f88a7bdf2 Some more steps in refactoring
unc0rr
parents: 2961
diff changeset
    71
4e4f88a7bdf2 Some more steps in refactoring
unc0rr
parents: 2961
diff changeset
    72
handleCmd_loggedin cmd = do
4e4f88a7bdf2 Some more steps in refactoring
unc0rr
parents: 2961
diff changeset
    73
    (ci, rnc) <- ask
4e4f88a7bdf2 Some more steps in refactoring
unc0rr
parents: 2961
diff changeset
    74
    if clientRoom rnc ci == lobbyId then
4e4f88a7bdf2 Some more steps in refactoring
unc0rr
parents: 2961
diff changeset
    75
        handleCmd_lobby cmd
4e4f88a7bdf2 Some more steps in refactoring
unc0rr
parents: 2961
diff changeset
    76
        else
4e4f88a7bdf2 Some more steps in refactoring
unc0rr
parents: 2961
diff changeset
    77
        handleCmd_inRoom cmd