gameServer/HWProtoNEState.hs
author unc0rr
Wed, 05 Mar 2014 00:53:08 +0400
changeset 10176 ea022e9483c2
parent 10077 ca67740f19b2
child 10212 5fb3bb2de9d2
permissions -rw-r--r--
Don't call halt()
Ignore whitespace changes - Everywhere: Within whitespace: At end of lines:
8372
3c193ec03e09 Logon procedure for checkers, introduce invisible clients
unc0rr
parents: 8371
diff changeset
     1
{-# LANGUAGE OverloadedStrings, CPP #-}
1804
4e78ad846fb6 New game server:
unc0rr
parents:
diff changeset
     2
module HWProtoNEState where
4e78ad846fb6 New game server:
unc0rr
parents:
diff changeset
     3
4295
1f5604cd99be This revision should, in theory, correctly merge 0.9.14 and tip, so that future merges of 0.9.14 should work properly
nemo
parents: 4242
diff changeset
     4
import Control.Monad.Reader
10076
b235e520ea21 Mutual authentication: server side
unc0rr
parents: 8401
diff changeset
     5
import qualified Data.ByteString.Lazy as BL
4295
1f5604cd99be This revision should, in theory, correctly merge 0.9.14 and tip, so that future merges of 0.9.14 should work properly
nemo
parents: 4242
diff changeset
     6
import qualified Data.ByteString.Char8 as B
10076
b235e520ea21 Mutual authentication: server side
unc0rr
parents: 8401
diff changeset
     7
import Data.Digest.Pure.SHA
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
4295
1f5604cd99be This revision should, in theory, correctly merge 0.9.14 and tip, so that future merges of 0.9.14 should work properly
nemo
parents: 4242
diff changeset
    12
import RoomsAndClients
1804
4e78ad846fb6 New game server:
unc0rr
parents:
diff changeset
    13
4989
4771fed9272e - Write server config into .ini file on change
unc0rr
parents: 4975
diff changeset
    14
handleCmd_NotEntered :: CmdHandler
1804
4e78ad846fb6 New game server:
unc0rr
parents:
diff changeset
    15
4295
1f5604cd99be This revision should, in theory, correctly merge 0.9.14 and tip, so that future merges of 0.9.14 should work properly
nemo
parents: 4242
diff changeset
    16
handleCmd_NotEntered ["NICK", newNick] = do
1f5604cd99be This revision should, in theory, correctly merge 0.9.14 and tip, so that future merges of 0.9.14 should work properly
nemo
parents: 4242
diff changeset
    17
    (ci, irnc) <- ask
1f5604cd99be This revision should, in theory, correctly merge 0.9.14 and tip, so that future merges of 0.9.14 should work properly
nemo
parents: 4242
diff changeset
    18
    let cl = irnc `client` ci
8401
87410ae372f6 Server messages localization using Qt's l10n subsystem:
unc0rr
parents: 8372
diff changeset
    19
    if not . B.null $ nick cl then return [ProtocolError $ loc "Nickname already chosen"]
4295
1f5604cd99be This revision should, in theory, correctly merge 0.9.14 and tip, so that future merges of 0.9.14 should work properly
nemo
parents: 4242
diff changeset
    20
        else
8401
87410ae372f6 Server messages localization using Qt's l10n subsystem:
unc0rr
parents: 8372
diff changeset
    21
        if illegalName newNick then return [ByeClient $ loc "Illegal nickname"]
4295
1f5604cd99be This revision should, in theory, correctly merge 0.9.14 and tip, so that future merges of 0.9.14 should work properly
nemo
parents: 4242
diff changeset
    22
            else
4991
90d1fb9fc2e1 Fix check for duplicated nickname
unc0rr
parents: 4989
diff changeset
    23
            return $
90d1fb9fc2e1 Fix check for duplicated nickname
unc0rr
parents: 4989
diff changeset
    24
                ModifyClient (\c -> c{nick = newNick}) :
90d1fb9fc2e1 Fix check for duplicated nickname
unc0rr
parents: 4989
diff changeset
    25
                AnswerClients [sendChan cl] ["NICK", newNick] :
90d1fb9fc2e1 Fix check for duplicated nickname
unc0rr
parents: 4989
diff changeset
    26
                [CheckRegistered | clientProto cl /= 0]
4295
1f5604cd99be This revision should, in theory, correctly merge 0.9.14 and tip, so that future merges of 0.9.14 should work properly
nemo
parents: 4242
diff changeset
    27
1f5604cd99be This revision should, in theory, correctly merge 0.9.14 and tip, so that future merges of 0.9.14 should work properly
nemo
parents: 4242
diff changeset
    28
handleCmd_NotEntered ["PROTO", protoNum] = do
1f5604cd99be This revision should, in theory, correctly merge 0.9.14 and tip, so that future merges of 0.9.14 should work properly
nemo
parents: 4242
diff changeset
    29
    (ci, irnc) <- ask
1f5604cd99be This revision should, in theory, correctly merge 0.9.14 and tip, so that future merges of 0.9.14 should work properly
nemo
parents: 4242
diff changeset
    30
    let cl = irnc `client` ci
8401
87410ae372f6 Server messages localization using Qt's l10n subsystem:
unc0rr
parents: 8372
diff changeset
    31
    if clientProto cl > 0 then return [ProtocolError $ loc "Protocol already known"]
4295
1f5604cd99be This revision should, in theory, correctly merge 0.9.14 and tip, so that future merges of 0.9.14 should work properly
nemo
parents: 4242
diff changeset
    32
        else
8401
87410ae372f6 Server messages localization using Qt's l10n subsystem:
unc0rr
parents: 8372
diff changeset
    33
        if parsedProto == 0 then return [ProtocolError $ loc "Bad number"]
4295
1f5604cd99be This revision should, in theory, correctly merge 0.9.14 and tip, so that future merges of 0.9.14 should work properly
nemo
parents: 4242
diff changeset
    34
            else
1f5604cd99be This revision should, in theory, correctly merge 0.9.14 and tip, so that future merges of 0.9.14 should work properly
nemo
parents: 4242
diff changeset
    35
            return $
1f5604cd99be This revision should, in theory, correctly merge 0.9.14 and tip, so that future merges of 0.9.14 should work properly
nemo
parents: 4242
diff changeset
    36
                ModifyClient (\c -> c{clientProto = parsedProto}) :
5030
42746c5d4a80 Changed the standard show function to Text.Show.ByteString, and misc.
EJ <eivind.jahren@gmail.com>
parents: 4991
diff changeset
    37
                AnswerClients [sendChan cl] ["PROTO", showB parsedProto] :
4295
1f5604cd99be This revision should, in theory, correctly merge 0.9.14 and tip, so that future merges of 0.9.14 should work properly
nemo
parents: 4242
diff changeset
    38
                [CheckRegistered | not . B.null $ nick cl]
1f5604cd99be This revision should, in theory, correctly merge 0.9.14 and tip, so that future merges of 0.9.14 should work properly
nemo
parents: 4242
diff changeset
    39
    where
5090
2922455e606e Use readInt_
unc0rr
parents: 5030
diff changeset
    40
        parsedProto = readInt_ protoNum
1841
fba7210b438b Retrieve client password from web database and ask for it
unc0rr
parents: 1834
diff changeset
    41
3536
7d99655130ff Partially reimplement joining rooms
unc0rr
parents: 3500
diff changeset
    42
4295
1f5604cd99be This revision should, in theory, correctly merge 0.9.14 and tip, so that future merges of 0.9.14 should work properly
nemo
parents: 4242
diff changeset
    43
handleCmd_NotEntered ["PASSWORD", passwd] = do
1f5604cd99be This revision should, in theory, correctly merge 0.9.14 and tip, so that future merges of 0.9.14 should work properly
nemo
parents: 4242
diff changeset
    44
    (ci, irnc) <- ask
1f5604cd99be This revision should, in theory, correctly merge 0.9.14 and tip, so that future merges of 0.9.14 should work properly
nemo
parents: 4242
diff changeset
    45
    let cl = irnc `client` ci
1879
bb114339eb4e Implement kick from room
unc0rr
parents: 1847
diff changeset
    46
10076
b235e520ea21 Mutual authentication: server side
unc0rr
parents: 8401
diff changeset
    47
    if clientProto cl < 48 && passwd == webPassword cl then
4295
1f5604cd99be This revision should, in theory, correctly merge 0.9.14 and tip, so that future merges of 0.9.14 should work properly
nemo
parents: 4242
diff changeset
    48
        return $ JoinLobby : [AnswerClients [sendChan cl] ["ADMIN_ACCESS"] | isAdministrator cl]
1f5604cd99be This revision should, in theory, correctly merge 0.9.14 and tip, so that future merges of 0.9.14 should work properly
nemo
parents: 4242
diff changeset
    49
        else
1f5604cd99be This revision should, in theory, correctly merge 0.9.14 and tip, so that future merges of 0.9.14 should work properly
nemo
parents: 4242
diff changeset
    50
        return [ByeClient "Authentication failed"]
1879
bb114339eb4e Implement kick from room
unc0rr
parents: 1847
diff changeset
    51
1804
4e78ad846fb6 New game server:
unc0rr
parents:
diff changeset
    52
10076
b235e520ea21 Mutual authentication: server side
unc0rr
parents: 8401
diff changeset
    53
handleCmd_NotEntered ["PASSWORD", passwd, clientSalt] = do
b235e520ea21 Mutual authentication: server side
unc0rr
parents: 8401
diff changeset
    54
    (ci, irnc) <- ask
b235e520ea21 Mutual authentication: server side
unc0rr
parents: 8401
diff changeset
    55
    let cl = irnc `client` ci
b235e520ea21 Mutual authentication: server side
unc0rr
parents: 8401
diff changeset
    56
b235e520ea21 Mutual authentication: server side
unc0rr
parents: 8401
diff changeset
    57
    let clientHash = h [clientSalt, serverSalt cl, webPassword cl, showB $ clientProto cl, "!hedgewars"]
b235e520ea21 Mutual authentication: server side
unc0rr
parents: 8401
diff changeset
    58
    let serverHash = h [serverSalt cl, clientSalt, webPassword cl, showB $ clientProto cl, "!hedgewars"]
b235e520ea21 Mutual authentication: server side
unc0rr
parents: 8401
diff changeset
    59
b235e520ea21 Mutual authentication: server side
unc0rr
parents: 8401
diff changeset
    60
    if passwd == clientHash then
10077
ca67740f19b2 ADMIN_ACCESS is deprecated long ago
unc0rr
parents: 10076
diff changeset
    61
        return [
10076
b235e520ea21 Mutual authentication: server side
unc0rr
parents: 8401
diff changeset
    62
            AnswerClients [sendChan cl] ["SERVER_AUTH", serverHash] 
10077
ca67740f19b2 ADMIN_ACCESS is deprecated long ago
unc0rr
parents: 10076
diff changeset
    63
            , JoinLobby
ca67740f19b2 ADMIN_ACCESS is deprecated long ago
unc0rr
parents: 10076
diff changeset
    64
            ]
10076
b235e520ea21 Mutual authentication: server side
unc0rr
parents: 8401
diff changeset
    65
        else
b235e520ea21 Mutual authentication: server side
unc0rr
parents: 8401
diff changeset
    66
        return [ByeClient "Authentication failed"]
b235e520ea21 Mutual authentication: server side
unc0rr
parents: 8401
diff changeset
    67
    where
b235e520ea21 Mutual authentication: server side
unc0rr
parents: 8401
diff changeset
    68
        h = B.pack . showDigest . sha1 . BL.fromChunks
b235e520ea21 Mutual authentication: server side
unc0rr
parents: 8401
diff changeset
    69
8372
3c193ec03e09 Logon procedure for checkers, introduce invisible clients
unc0rr
parents: 8371
diff changeset
    70
#if defined(OFFICIAL_SERVER)
8371
0551b5c3de9a - Start work on checker
unc0rr
parents: 5090
diff changeset
    71
handleCmd_NotEntered ["CHECKER", protoNum, newNick, password] = do
0551b5c3de9a - Start work on checker
unc0rr
parents: 5090
diff changeset
    72
    (ci, irnc) <- ask
0551b5c3de9a - Start work on checker
unc0rr
parents: 5090
diff changeset
    73
    let cl = irnc `client` ci
0551b5c3de9a - Start work on checker
unc0rr
parents: 5090
diff changeset
    74
8401
87410ae372f6 Server messages localization using Qt's l10n subsystem:
unc0rr
parents: 8372
diff changeset
    75
    if parsedProto == 0 then return [ProtocolError $ loc "Bad number"]
8371
0551b5c3de9a - Start work on checker
unc0rr
parents: 5090
diff changeset
    76
        else
0551b5c3de9a - Start work on checker
unc0rr
parents: 5090
diff changeset
    77
        return $ [
0551b5c3de9a - Start work on checker
unc0rr
parents: 5090
diff changeset
    78
            ModifyClient (\c -> c{clientProto = parsedProto, nick = newNick, webPassword = password, isChecker = True})
0551b5c3de9a - Start work on checker
unc0rr
parents: 5090
diff changeset
    79
            , CheckRegistered]
0551b5c3de9a - Start work on checker
unc0rr
parents: 5090
diff changeset
    80
    where
0551b5c3de9a - Start work on checker
unc0rr
parents: 5090
diff changeset
    81
        parsedProto = readInt_ protoNum
8372
3c193ec03e09 Logon procedure for checkers, introduce invisible clients
unc0rr
parents: 8371
diff changeset
    82
#endif
8371
0551b5c3de9a - Start work on checker
unc0rr
parents: 5090
diff changeset
    83
4295
1f5604cd99be This revision should, in theory, correctly merge 0.9.14 and tip, so that future merges of 0.9.14 should work properly
nemo
parents: 4242
diff changeset
    84
handleCmd_NotEntered _ = return [ProtocolError "Incorrect command (state: not entered)"]