gameServer/HWProtoCore.hs
author koda
Sat, 17 Jul 2010 03:59:10 +0200
changeset 3647 0d0df215fb52
parent 3500 af8390d807d6
child 3671 a94d1dc4a8d9
permissions -rw-r--r--
making chat work... (keyboard support is heavily broken in sdl upstream)
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