gameServer/HWProtoNEState.hs
author nemo
Sun, 20 Jun 2010 22:46:23 -0400
changeset 3528 0ad90165fde0
parent 3500 af8390d807d6
child 3536 7d99655130ff
permissions -rw-r--r--
disable uSHA, enable adler32
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)"]