gameServer/HWProtoNEState.hs
author szczur
Sun, 12 Sep 2010 17:38:14 -0400
changeset 3850 df6ecca1894f
parent 3671 a94d1dc4a8d9
child 4242 5e3c5fe2cb14
permissions -rw-r--r--
This change allows computers limited to 512 texture size like szczur's card to run Hedgewars, so long as reduce quality is set to eliminate background textures. It makes Ammo menu and Hats multicolumn, 512 high.
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 HWProtoNEState 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
3671
a94d1dc4a8d9 - burp's patch cleaning up module dependancies + cabal file
unc0rr
parents: 3566
diff changeset
     5
import Data.Maybe
1804
4e78ad846fb6 New game server:
unc0rr
parents:
diff changeset
     6
import Data.List
4e78ad846fb6 New game server:
unc0rr
parents:
diff changeset
     7
import Data.Word
3458
11cd56019f00 Make some more protocol commands work
unc0rr
parents: 3435
diff changeset
     8
import Control.Monad.Reader
3500
af8390d807d6 Use sockets instead of handles, use bytestrings instead of strings
unc0rr
parents: 3458
diff changeset
     9
import qualified Data.ByteString.Char8 as B
1804
4e78ad846fb6 New game server:
unc0rr
parents:
diff changeset
    10
--------------------------------------
4e78ad846fb6 New game server:
unc0rr
parents:
diff changeset
    11
import CoreTypes
4e78ad846fb6 New game server:
unc0rr
parents:
diff changeset
    12
import Actions
4e78ad846fb6 New game server:
unc0rr
parents:
diff changeset
    13
import Utils
3458
11cd56019f00 Make some more protocol commands work
unc0rr
parents: 3435
diff changeset
    14
import RoomsAndClients
1804
4e78ad846fb6 New game server:
unc0rr
parents:
diff changeset
    15
4e78ad846fb6 New game server:
unc0rr
parents:
diff changeset
    16
handleCmd_NotEntered :: CmdHandler
4e78ad846fb6 New game server:
unc0rr
parents:
diff changeset
    17
3458
11cd56019f00 Make some more protocol commands work
unc0rr
parents: 3435
diff changeset
    18
handleCmd_NotEntered ["NICK", newNick] = do
11cd56019f00 Make some more protocol commands work
unc0rr
parents: 3435
diff changeset
    19
    (ci, irnc) <- ask
11cd56019f00 Make some more protocol commands work
unc0rr
parents: 3435
diff changeset
    20
    let cl = irnc `client` ci
3500
af8390d807d6 Use sockets instead of handles, use bytestrings instead of strings
unc0rr
parents: 3458
diff changeset
    21
    if not . B.null $ nick cl then return [ProtocolError "Nickname already chosen"]
3458
11cd56019f00 Make some more protocol commands work
unc0rr
parents: 3435
diff changeset
    22
        else
3538
b11ac2677e42 Restore test for already used nick
unc0rr
parents: 3536
diff changeset
    23
        if haveSameNick irnc (nick cl) then return [AnswerClients [sendChan cl] ["WARNING", "Nickname already in use"], ByeClient ""]
b11ac2677e42 Restore test for already used nick
unc0rr
parents: 3536
diff changeset
    24
            else
3458
11cd56019f00 Make some more protocol commands work
unc0rr
parents: 3435
diff changeset
    25
            if illegalName newNick then return [ByeClient "Illegal nickname"]
11cd56019f00 Make some more protocol commands work
unc0rr
parents: 3435
diff changeset
    26
                else
11cd56019f00 Make some more protocol commands work
unc0rr
parents: 3435
diff changeset
    27
                return $
11cd56019f00 Make some more protocol commands work
unc0rr
parents: 3435
diff changeset
    28
                    ModifyClient (\c -> c{nick = newNick}) :
11cd56019f00 Make some more protocol commands work
unc0rr
parents: 3435
diff changeset
    29
                    AnswerClients [sendChan cl] ["NICK", newNick] :
11cd56019f00 Make some more protocol commands work
unc0rr
parents: 3435
diff changeset
    30
                    [CheckRegistered | clientProto cl /= 0]
2867
9be6693c78cb - Unbreak support for client versions prior to 0.9.13-dev
unc0rr
parents: 2747
diff changeset
    31
    where
3538
b11ac2677e42 Restore test for already used nick
unc0rr
parents: 3536
diff changeset
    32
    haveSameNick irnc clNick = isJust $ find (\cl -> newNick == clNick) $ map (client irnc) $ allClients irnc
3536
7d99655130ff Partially reimplement joining rooms
unc0rr
parents: 3500
diff changeset
    33
3458
11cd56019f00 Make some more protocol commands work
unc0rr
parents: 3435
diff changeset
    34
handleCmd_NotEntered ["PROTO", protoNum] = do
11cd56019f00 Make some more protocol commands work
unc0rr
parents: 3435
diff changeset
    35
    (ci, irnc) <- ask
11cd56019f00 Make some more protocol commands work
unc0rr
parents: 3435
diff changeset
    36
    let cl = irnc `client` ci
11cd56019f00 Make some more protocol commands work
unc0rr
parents: 3435
diff changeset
    37
    if clientProto cl > 0 then return [ProtocolError "Protocol already known"]
3566
772a46ef8288 Properly handle client exit
unc0rr
parents: 3538
diff changeset
    38
        else
3458
11cd56019f00 Make some more protocol commands work
unc0rr
parents: 3435
diff changeset
    39
        if parsedProto == 0 then return [ProtocolError "Bad number"]
3566
772a46ef8288 Properly handle client exit
unc0rr
parents: 3538
diff changeset
    40
            else
3458
11cd56019f00 Make some more protocol commands work
unc0rr
parents: 3435
diff changeset
    41
            return $
11cd56019f00 Make some more protocol commands work
unc0rr
parents: 3435
diff changeset
    42
                ModifyClient (\c -> c{clientProto = parsedProto}) :
3500
af8390d807d6 Use sockets instead of handles, use bytestrings instead of strings
unc0rr
parents: 3458
diff changeset
    43
                AnswerClients [sendChan cl] ["PROTO", B.pack $ show parsedProto] :
af8390d807d6 Use sockets instead of handles, use bytestrings instead of strings
unc0rr
parents: 3458
diff changeset
    44
                [CheckRegistered | not . B.null $ nick cl]
2867
9be6693c78cb - Unbreak support for client versions prior to 0.9.13-dev
unc0rr
parents: 2747
diff changeset
    45
    where
3500
af8390d807d6 Use sockets instead of handles, use bytestrings instead of strings
unc0rr
parents: 3458
diff changeset
    46
        parsedProto = case B.readInt protoNum of
af8390d807d6 Use sockets instead of handles, use bytestrings instead of strings
unc0rr
parents: 3458
diff changeset
    47
                           Just (i, t) | B.null t -> fromIntegral i
af8390d807d6 Use sockets instead of handles, use bytestrings instead of strings
unc0rr
parents: 3458
diff changeset
    48
                           otherwise -> 0
1841
fba7210b438b Retrieve client password from web database and ask for it
unc0rr
parents: 1834
diff changeset
    49
3536
7d99655130ff Partially reimplement joining rooms
unc0rr
parents: 3500
diff changeset
    50
7d99655130ff Partially reimplement joining rooms
unc0rr
parents: 3500
diff changeset
    51
handleCmd_NotEntered ["PASSWORD", passwd] = do
7d99655130ff Partially reimplement joining rooms
unc0rr
parents: 3500
diff changeset
    52
    (ci, irnc) <- ask
7d99655130ff Partially reimplement joining rooms
unc0rr
parents: 3500
diff changeset
    53
    let cl = irnc `client` ci
1879
bb114339eb4e Implement kick from room
unc0rr
parents: 1847
diff changeset
    54
3536
7d99655130ff Partially reimplement joining rooms
unc0rr
parents: 3500
diff changeset
    55
    if passwd == webPassword cl then
7d99655130ff Partially reimplement joining rooms
unc0rr
parents: 3500
diff changeset
    56
        return $ JoinLobby : [AnswerClients [sendChan cl] ["ADMIN_ACCESS"] | isAdministrator cl]
7d99655130ff Partially reimplement joining rooms
unc0rr
parents: 3500
diff changeset
    57
        else
7d99655130ff Partially reimplement joining rooms
unc0rr
parents: 3500
diff changeset
    58
        return [ByeClient "Authentication failed"]
1804
4e78ad846fb6 New game server:
unc0rr
parents:
diff changeset
    59
3536
7d99655130ff Partially reimplement joining rooms
unc0rr
parents: 3500
diff changeset
    60
{-
1804
4e78ad846fb6 New game server:
unc0rr
parents:
diff changeset
    61
2868
ccb20ecd3503 Some debug stuff
unc0rr
parents: 2867
diff changeset
    62
handleCmd_NotEntered clID clients _ ["DUMP"] =
ccb20ecd3503 Some debug stuff
unc0rr
parents: 2867
diff changeset
    63
    if isAdministrator (clients IntMap.! clID) then [Dump] else []
3435
4e4f88a7bdf2 Some more steps in refactoring
unc0rr
parents: 2868
diff changeset
    64
-}
1804
4e78ad846fb6 New game server:
unc0rr
parents:
diff changeset
    65
3435
4e4f88a7bdf2 Some more steps in refactoring
unc0rr
parents: 2868
diff changeset
    66
handleCmd_NotEntered _ = return [ProtocolError "Incorrect command (state: not entered)"]