gameServer/HWProtoNEState.hs
author nemo
Sun, 20 Jun 2010 22:35:10 -0400
changeset 3526 a1d2180fef42
parent 3500 af8390d807d6
child 3536 7d99655130ff
permissions -rw-r--r--
Replace SHA1 with adler32. For simple purposes of checking to see if players are playing the same map, this should be quite adequate and runs 15 times faster.
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
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"]
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
        if parsedProto == 0 then return [ProtocolError "Bad number"]
11cd56019f00 Make some more protocol commands work
unc0rr
parents: 3435
diff changeset
    40
            else 
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
3458
11cd56019f00 Make some more protocol commands work
unc0rr
parents: 3435
diff changeset
    50
{-
1879
bb114339eb4e Implement kick from room
unc0rr
parents: 1847
diff changeset
    51
1844
81abed9d4c11 Ask user password and send it to server
unc0rr
parents: 1841
diff changeset
    52
handleCmd_NotEntered clID clients _ ["PASSWORD", passwd] =
2867
9be6693c78cb - Unbreak support for client versions prior to 0.9.13-dev
unc0rr
parents: 2747
diff changeset
    53
    if passwd == webPassword client then
9be6693c78cb - Unbreak support for client versions prior to 0.9.13-dev
unc0rr
parents: 2747
diff changeset
    54
        [ModifyClient (\cl -> cl{logonPassed = True}),
9be6693c78cb - Unbreak support for client versions prior to 0.9.13-dev
unc0rr
parents: 2747
diff changeset
    55
        MoveToLobby] ++ adminNotice
9be6693c78cb - Unbreak support for client versions prior to 0.9.13-dev
unc0rr
parents: 2747
diff changeset
    56
    else
9be6693c78cb - Unbreak support for client versions prior to 0.9.13-dev
unc0rr
parents: 2747
diff changeset
    57
        [ByeClient "Authentication failed"]
9be6693c78cb - Unbreak support for client versions prior to 0.9.13-dev
unc0rr
parents: 2747
diff changeset
    58
    where
9be6693c78cb - Unbreak support for client versions prior to 0.9.13-dev
unc0rr
parents: 2747
diff changeset
    59
        client = clients IntMap.! clID
9be6693c78cb - Unbreak support for client versions prior to 0.9.13-dev
unc0rr
parents: 2747
diff changeset
    60
        adminNotice = [AnswerThisClient ["ADMIN_ACCESS"] | isAdministrator client]
1804
4e78ad846fb6 New game server:
unc0rr
parents:
diff changeset
    61
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)"]