gameServer/HWProtoNEState.hs
author sheepluva
Tue, 29 Jun 2010 06:27:59 +0200
changeset 3584 7c05f2e0a8b5
parent 3566 772a46ef8288
child 3671 a94d1dc4a8d9
permissions -rw-r--r--
rope: another small optimization
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
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)"]