gameServer/HWProtoNEState.hs
author koda
Sat, 05 Jun 2010 14:07:58 +0000
changeset 3495 a6b4f351d400
parent 3458 11cd56019f00
child 3500 af8390d807d6
permissions -rw-r--r--
now engine can be optionally built as library, there's an example wrapper of how to use it building server is now disabled by default, saves users some headaches
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)"]