gameServer/HWProtoNEState.hs
author unc0rr
Tue, 22 Jun 2010 22:21:44 +0400
changeset 3536 7d99655130ff
parent 3500 af8390d807d6
child 3538 b11ac2677e42
permissions -rw-r--r--
Partially reimplement joining rooms
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
4e78ad846fb6 New game server:
unc0rr
parents:
diff changeset
     5
import Maybe
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
11cd56019f00 Make some more protocol commands work
unc0rr
parents: 3435
diff changeset
    23
        if haveSameNick irnc then return [AnswerClients [sendChan cl] ["WARNING", "Nickname already in use"], ByeClient ""]
11cd56019f00 Make some more protocol commands work
unc0rr
parents: 3435
diff changeset
    24
            else 
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
3458
11cd56019f00 Make some more protocol commands work
unc0rr
parents: 3435
diff changeset
    32
        haveSameNick irnc = False --isJust $ find (\cl -> newNick == nick cl) $ IntMap.elems clients
1804
4e78ad846fb6 New game server:
unc0rr
parents:
diff changeset
    33
3536
7d99655130ff Partially reimplement joining rooms
unc0rr
parents: 3500
diff changeset
    34
3458
11cd56019f00 Make some more protocol commands work
unc0rr
parents: 3435
diff changeset
    35
handleCmd_NotEntered ["PROTO", protoNum] = do
11cd56019f00 Make some more protocol commands work
unc0rr
parents: 3435
diff changeset
    36
    (ci, irnc) <- ask
11cd56019f00 Make some more protocol commands work
unc0rr
parents: 3435
diff changeset
    37
    let cl = irnc `client` ci
11cd56019f00 Make some more protocol commands work
unc0rr
parents: 3435
diff changeset
    38
    if clientProto cl > 0 then return [ProtocolError "Protocol already known"]
11cd56019f00 Make some more protocol commands work
unc0rr
parents: 3435
diff changeset
    39
        else 
11cd56019f00 Make some more protocol commands work
unc0rr
parents: 3435
diff changeset
    40
        if parsedProto == 0 then return [ProtocolError "Bad number"]
11cd56019f00 Make some more protocol commands work
unc0rr
parents: 3435
diff changeset
    41
            else 
11cd56019f00 Make some more protocol commands work
unc0rr
parents: 3435
diff changeset
    42
            return $
11cd56019f00 Make some more protocol commands work
unc0rr
parents: 3435
diff changeset
    43
                ModifyClient (\c -> c{clientProto = parsedProto}) :
3500
af8390d807d6 Use sockets instead of handles, use bytestrings instead of strings
unc0rr
parents: 3458
diff changeset
    44
                AnswerClients [sendChan cl] ["PROTO", B.pack $ show parsedProto] :
af8390d807d6 Use sockets instead of handles, use bytestrings instead of strings
unc0rr
parents: 3458
diff changeset
    45
                [CheckRegistered | not . B.null $ nick cl]
2867
9be6693c78cb - Unbreak support for client versions prior to 0.9.13-dev
unc0rr
parents: 2747
diff changeset
    46
    where
3500
af8390d807d6 Use sockets instead of handles, use bytestrings instead of strings
unc0rr
parents: 3458
diff changeset
    47
        parsedProto = case B.readInt protoNum of
af8390d807d6 Use sockets instead of handles, use bytestrings instead of strings
unc0rr
parents: 3458
diff changeset
    48
                           Just (i, t) | B.null t -> fromIntegral i
af8390d807d6 Use sockets instead of handles, use bytestrings instead of strings
unc0rr
parents: 3458
diff changeset
    49
                           otherwise -> 0
1841
fba7210b438b Retrieve client password from web database and ask for it
unc0rr
parents: 1834
diff changeset
    50
3536
7d99655130ff Partially reimplement joining rooms
unc0rr
parents: 3500
diff changeset
    51
7d99655130ff Partially reimplement joining rooms
unc0rr
parents: 3500
diff changeset
    52
handleCmd_NotEntered ["PASSWORD", passwd] = do
7d99655130ff Partially reimplement joining rooms
unc0rr
parents: 3500
diff changeset
    53
    (ci, irnc) <- ask
7d99655130ff Partially reimplement joining rooms
unc0rr
parents: 3500
diff changeset
    54
    let cl = irnc `client` ci
1879
bb114339eb4e Implement kick from room
unc0rr
parents: 1847
diff changeset
    55
3536
7d99655130ff Partially reimplement joining rooms
unc0rr
parents: 3500
diff changeset
    56
    if passwd == webPassword cl then
7d99655130ff Partially reimplement joining rooms
unc0rr
parents: 3500
diff changeset
    57
        return $ JoinLobby : [AnswerClients [sendChan cl] ["ADMIN_ACCESS"] | isAdministrator cl]
7d99655130ff Partially reimplement joining rooms
unc0rr
parents: 3500
diff changeset
    58
        else
7d99655130ff Partially reimplement joining rooms
unc0rr
parents: 3500
diff changeset
    59
        return [ByeClient "Authentication failed"]
1804
4e78ad846fb6 New game server:
unc0rr
parents:
diff changeset
    60
3536
7d99655130ff Partially reimplement joining rooms
unc0rr
parents: 3500
diff changeset
    61
{-
1804
4e78ad846fb6 New game server:
unc0rr
parents:
diff changeset
    62
2868
ccb20ecd3503 Some debug stuff
unc0rr
parents: 2867
diff changeset
    63
handleCmd_NotEntered clID clients _ ["DUMP"] =
ccb20ecd3503 Some debug stuff
unc0rr
parents: 2867
diff changeset
    64
    if isAdministrator (clients IntMap.! clID) then [Dump] else []
3435
4e4f88a7bdf2 Some more steps in refactoring
unc0rr
parents: 2868
diff changeset
    65
-}
1804
4e78ad846fb6 New game server:
unc0rr
parents:
diff changeset
    66
3435
4e4f88a7bdf2 Some more steps in refactoring
unc0rr
parents: 2868
diff changeset
    67
handleCmd_NotEntered _ = return [ProtocolError "Incorrect command (state: not entered)"]