gameServer/HWProtoNEState.hs
author nemo
Sat, 01 Mar 2014 14:52:36 -0500
changeset 10171 00f41ff0bf2d
parent 10077 ca67740f19b2
child 10212 5fb3bb2de9d2
permissions -rw-r--r--
Script might well override a static map, but can't risk it not doing it, and preview completely failing. Better to just not try it for static maps. Some script cfg might help. Could also avoid unnnecessary preview regenerations even if the script was doing nothing at all.
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)"]