gameServer/HWProtoNEState.hs
author sheepluva
Mon, 17 May 2010 09:45:46 +0000
changeset 3472 b1832a3761e6
parent 3458 11cd56019f00
child 3500 af8390d807d6
permissions -rw-r--r--
portal-link-bugfix: make sure deleted portals don't reset links other than those to themselves
Ignore whitespace changes - Everywhere: Within whitespace: At end of lines:
1804
4e78ad846fb6 New game server:
unc0rr
parents:
diff changeset
     1
module HWProtoNEState where
4e78ad846fb6 New game server:
unc0rr
parents:
diff changeset
     2
4e78ad846fb6 New game server:
unc0rr
parents:
diff changeset
     3
import qualified Data.IntMap as IntMap
4e78ad846fb6 New game server:
unc0rr
parents:
diff changeset
     4
import Maybe
4e78ad846fb6 New game server:
unc0rr
parents:
diff changeset
     5
import Data.List
4e78ad846fb6 New game server:
unc0rr
parents:
diff changeset
     6
import Data.Word
3458
11cd56019f00 Make some more protocol commands work
unc0rr
parents: 3435
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
3458
11cd56019f00 Make some more protocol commands work
unc0rr
parents: 3435
diff changeset
    12
import RoomsAndClients
1804
4e78ad846fb6 New game server:
unc0rr
parents:
diff changeset
    13
4e78ad846fb6 New game server:
unc0rr
parents:
diff changeset
    14
handleCmd_NotEntered :: CmdHandler
4e78ad846fb6 New game server:
unc0rr
parents:
diff changeset
    15
3458
11cd56019f00 Make some more protocol commands work
unc0rr
parents: 3435
diff changeset
    16
handleCmd_NotEntered ["NICK", newNick] = do
11cd56019f00 Make some more protocol commands work
unc0rr
parents: 3435
diff changeset
    17
    (ci, irnc) <- ask
11cd56019f00 Make some more protocol commands work
unc0rr
parents: 3435
diff changeset
    18
    let cl = irnc `client` ci
11cd56019f00 Make some more protocol commands work
unc0rr
parents: 3435
diff changeset
    19
    if not . null $ nick cl then return [ProtocolError "Nickname already chosen"]
11cd56019f00 Make some more protocol commands work
unc0rr
parents: 3435
diff changeset
    20
        else
11cd56019f00 Make some more protocol commands work
unc0rr
parents: 3435
diff changeset
    21
        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
    22
            else 
11cd56019f00 Make some more protocol commands work
unc0rr
parents: 3435
diff changeset
    23
            if illegalName newNick then return [ByeClient "Illegal nickname"]
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
                return $
11cd56019f00 Make some more protocol commands work
unc0rr
parents: 3435
diff changeset
    26
                    ModifyClient (\c -> c{nick = newNick}) :
11cd56019f00 Make some more protocol commands work
unc0rr
parents: 3435
diff changeset
    27
                    AnswerClients [sendChan cl] ["NICK", newNick] :
11cd56019f00 Make some more protocol commands work
unc0rr
parents: 3435
diff changeset
    28
                    [CheckRegistered | clientProto cl /= 0]
2867
9be6693c78cb - Unbreak support for client versions prior to 0.9.13-dev
unc0rr
parents: 2747
diff changeset
    29
    where
3458
11cd56019f00 Make some more protocol commands work
unc0rr
parents: 3435
diff changeset
    30
        haveSameNick irnc = False --isJust $ find (\cl -> newNick == nick cl) $ IntMap.elems clients
1804
4e78ad846fb6 New game server:
unc0rr
parents:
diff changeset
    31
3458
11cd56019f00 Make some more protocol commands work
unc0rr
parents: 3435
diff changeset
    32
handleCmd_NotEntered ["PROTO", protoNum] = do
11cd56019f00 Make some more protocol commands work
unc0rr
parents: 3435
diff changeset
    33
    (ci, irnc) <- ask
11cd56019f00 Make some more protocol commands work
unc0rr
parents: 3435
diff changeset
    34
    let cl = irnc `client` ci
11cd56019f00 Make some more protocol commands work
unc0rr
parents: 3435
diff changeset
    35
    if clientProto cl > 0 then return [ProtocolError "Protocol already known"]
11cd56019f00 Make some more protocol commands work
unc0rr
parents: 3435
diff changeset
    36
        else 
11cd56019f00 Make some more protocol commands work
unc0rr
parents: 3435
diff changeset
    37
        if parsedProto == 0 then return [ProtocolError "Bad number"]
11cd56019f00 Make some more protocol commands work
unc0rr
parents: 3435
diff changeset
    38
            else 
11cd56019f00 Make some more protocol commands work
unc0rr
parents: 3435
diff changeset
    39
            return $
11cd56019f00 Make some more protocol commands work
unc0rr
parents: 3435
diff changeset
    40
                ModifyClient (\c -> c{clientProto = parsedProto}) :
11cd56019f00 Make some more protocol commands work
unc0rr
parents: 3435
diff changeset
    41
                AnswerClients [sendChan cl] ["PROTO", show parsedProto] :
11cd56019f00 Make some more protocol commands work
unc0rr
parents: 3435
diff changeset
    42
                [CheckRegistered | (not . null) (nick cl)]
2867
9be6693c78cb - Unbreak support for client versions prior to 0.9.13-dev
unc0rr
parents: 2747
diff changeset
    43
    where
9be6693c78cb - Unbreak support for client versions prior to 0.9.13-dev
unc0rr
parents: 2747
diff changeset
    44
        parsedProto = fromMaybe 0 (maybeRead protoNum :: Maybe Word16)
1841
fba7210b438b Retrieve client password from web database and ask for it
unc0rr
parents: 1834
diff changeset
    45
3458
11cd56019f00 Make some more protocol commands work
unc0rr
parents: 3435
diff changeset
    46
{-
1879
bb114339eb4e Implement kick from room
unc0rr
parents: 1847
diff changeset
    47
1844
81abed9d4c11 Ask user password and send it to server
unc0rr
parents: 1841
diff changeset
    48
handleCmd_NotEntered clID clients _ ["PASSWORD", passwd] =
2867
9be6693c78cb - Unbreak support for client versions prior to 0.9.13-dev
unc0rr
parents: 2747
diff changeset
    49
    if passwd == webPassword client then
9be6693c78cb - Unbreak support for client versions prior to 0.9.13-dev
unc0rr
parents: 2747
diff changeset
    50
        [ModifyClient (\cl -> cl{logonPassed = True}),
9be6693c78cb - Unbreak support for client versions prior to 0.9.13-dev
unc0rr
parents: 2747
diff changeset
    51
        MoveToLobby] ++ adminNotice
9be6693c78cb - Unbreak support for client versions prior to 0.9.13-dev
unc0rr
parents: 2747
diff changeset
    52
    else
9be6693c78cb - Unbreak support for client versions prior to 0.9.13-dev
unc0rr
parents: 2747
diff changeset
    53
        [ByeClient "Authentication failed"]
9be6693c78cb - Unbreak support for client versions prior to 0.9.13-dev
unc0rr
parents: 2747
diff changeset
    54
    where
9be6693c78cb - Unbreak support for client versions prior to 0.9.13-dev
unc0rr
parents: 2747
diff changeset
    55
        client = clients IntMap.! clID
9be6693c78cb - Unbreak support for client versions prior to 0.9.13-dev
unc0rr
parents: 2747
diff changeset
    56
        adminNotice = [AnswerThisClient ["ADMIN_ACCESS"] | isAdministrator client]
1804
4e78ad846fb6 New game server:
unc0rr
parents:
diff changeset
    57
4e78ad846fb6 New game server:
unc0rr
parents:
diff changeset
    58
2868
ccb20ecd3503 Some debug stuff
unc0rr
parents: 2867
diff changeset
    59
handleCmd_NotEntered clID clients _ ["DUMP"] =
ccb20ecd3503 Some debug stuff
unc0rr
parents: 2867
diff changeset
    60
    if isAdministrator (clients IntMap.! clID) then [Dump] else []
3435
4e4f88a7bdf2 Some more steps in refactoring
unc0rr
parents: 2868
diff changeset
    61
-}
1804
4e78ad846fb6 New game server:
unc0rr
parents:
diff changeset
    62
3435
4e4f88a7bdf2 Some more steps in refactoring
unc0rr
parents: 2868
diff changeset
    63
handleCmd_NotEntered _ = return [ProtocolError "Incorrect command (state: not entered)"]