gameServer/HWProtoNEState.hs
author koda
Mon, 16 Nov 2015 15:21:20 +0100
changeset 11398 c3a535886806
parent 11046 47a8c19ecb60
child 13079 81c154fd4380
permissions -rw-r--r--
pas2c: Tentatively fix the build
Ignore whitespace changes - Everywhere: Within whitespace: At end of lines:
10460
8dcea9087d75 Added copyrights to gameServer directory
Gianfranco Costamagna <costamagnagianfranco@yahoo.it>
parents: 10212
diff changeset
     1
{-
8dcea9087d75 Added copyrights to gameServer directory
Gianfranco Costamagna <costamagnagianfranco@yahoo.it>
parents: 10212
diff changeset
     2
 * Hedgewars, a free turn based strategy game
11046
47a8c19ecb60 more copyright fixes
sheepluva
parents: 10460
diff changeset
     3
 * Copyright (c) 2004-2015 Andrey Korotaev <unC0Rr@gmail.com>
10460
8dcea9087d75 Added copyrights to gameServer directory
Gianfranco Costamagna <costamagnagianfranco@yahoo.it>
parents: 10212
diff changeset
     4
 *
8dcea9087d75 Added copyrights to gameServer directory
Gianfranco Costamagna <costamagnagianfranco@yahoo.it>
parents: 10212
diff changeset
     5
 * This program is free software; you can redistribute it and/or modify
8dcea9087d75 Added copyrights to gameServer directory
Gianfranco Costamagna <costamagnagianfranco@yahoo.it>
parents: 10212
diff changeset
     6
 * it under the terms of the GNU General Public License as published by
8dcea9087d75 Added copyrights to gameServer directory
Gianfranco Costamagna <costamagnagianfranco@yahoo.it>
parents: 10212
diff changeset
     7
 * the Free Software Foundation; version 2 of the License
8dcea9087d75 Added copyrights to gameServer directory
Gianfranco Costamagna <costamagnagianfranco@yahoo.it>
parents: 10212
diff changeset
     8
 *
8dcea9087d75 Added copyrights to gameServer directory
Gianfranco Costamagna <costamagnagianfranco@yahoo.it>
parents: 10212
diff changeset
     9
 * This program is distributed in the hope that it will be useful,
8dcea9087d75 Added copyrights to gameServer directory
Gianfranco Costamagna <costamagnagianfranco@yahoo.it>
parents: 10212
diff changeset
    10
 * but WITHOUT ANY WARRANTY; without even the implied warranty of
8dcea9087d75 Added copyrights to gameServer directory
Gianfranco Costamagna <costamagnagianfranco@yahoo.it>
parents: 10212
diff changeset
    11
 * MERCHANTABILITY or FITNESS FOR A PARTICULAR PURPOSE.  See the
8dcea9087d75 Added copyrights to gameServer directory
Gianfranco Costamagna <costamagnagianfranco@yahoo.it>
parents: 10212
diff changeset
    12
 * GNU General Public License for more details.
8dcea9087d75 Added copyrights to gameServer directory
Gianfranco Costamagna <costamagnagianfranco@yahoo.it>
parents: 10212
diff changeset
    13
 *
8dcea9087d75 Added copyrights to gameServer directory
Gianfranco Costamagna <costamagnagianfranco@yahoo.it>
parents: 10212
diff changeset
    14
 * You should have received a copy of the GNU General Public License
8dcea9087d75 Added copyrights to gameServer directory
Gianfranco Costamagna <costamagnagianfranco@yahoo.it>
parents: 10212
diff changeset
    15
 * along with this program; if not, write to the Free Software
8dcea9087d75 Added copyrights to gameServer directory
Gianfranco Costamagna <costamagnagianfranco@yahoo.it>
parents: 10212
diff changeset
    16
 * Foundation, Inc., 51 Franklin Street, Fifth Floor, Boston, MA 02110-1301 USA.
8dcea9087d75 Added copyrights to gameServer directory
Gianfranco Costamagna <costamagnagianfranco@yahoo.it>
parents: 10212
diff changeset
    17
 \-}
8dcea9087d75 Added copyrights to gameServer directory
Gianfranco Costamagna <costamagnagianfranco@yahoo.it>
parents: 10212
diff changeset
    18
8372
3c193ec03e09 Logon procedure for checkers, introduce invisible clients
unc0rr
parents: 8371
diff changeset
    19
{-# LANGUAGE OverloadedStrings, CPP #-}
1804
4e78ad846fb6 New game server:
unc0rr
parents:
diff changeset
    20
module HWProtoNEState where
4e78ad846fb6 New game server:
unc0rr
parents:
diff changeset
    21
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
import Control.Monad.Reader
10076
b235e520ea21 Mutual authentication: server side
unc0rr
parents: 8401
diff changeset
    23
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
    24
import qualified Data.ByteString.Char8 as B
10076
b235e520ea21 Mutual authentication: server side
unc0rr
parents: 8401
diff changeset
    25
import Data.Digest.Pure.SHA
1804
4e78ad846fb6 New game server:
unc0rr
parents:
diff changeset
    26
--------------------------------------
4e78ad846fb6 New game server:
unc0rr
parents:
diff changeset
    27
import CoreTypes
4e78ad846fb6 New game server:
unc0rr
parents:
diff changeset
    28
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
    29
import RoomsAndClients
10212
5fb3bb2de9d2 Some fixes to voting + small refactoring
unc0rr
parents: 10077
diff changeset
    30
import HandlerUtils
1804
4e78ad846fb6 New game server:
unc0rr
parents:
diff changeset
    31
4989
4771fed9272e - Write server config into .ini file on change
unc0rr
parents: 4975
diff changeset
    32
handleCmd_NotEntered :: CmdHandler
1804
4e78ad846fb6 New game server:
unc0rr
parents:
diff changeset
    33
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
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
    35
    (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
    36
    let cl = irnc `client` ci
8401
87410ae372f6 Server messages localization using Qt's l10n subsystem:
unc0rr
parents: 8372
diff changeset
    37
    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
    38
        else
8401
87410ae372f6 Server messages localization using Qt's l10n subsystem:
unc0rr
parents: 8372
diff changeset
    39
        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
    40
            else
4991
90d1fb9fc2e1 Fix check for duplicated nickname
unc0rr
parents: 4989
diff changeset
    41
            return $
90d1fb9fc2e1 Fix check for duplicated nickname
unc0rr
parents: 4989
diff changeset
    42
                ModifyClient (\c -> c{nick = newNick}) :
90d1fb9fc2e1 Fix check for duplicated nickname
unc0rr
parents: 4989
diff changeset
    43
                AnswerClients [sendChan cl] ["NICK", newNick] :
90d1fb9fc2e1 Fix check for duplicated nickname
unc0rr
parents: 4989
diff changeset
    44
                [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
    45
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
    46
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
    47
    (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
    48
    let cl = irnc `client` ci
8401
87410ae372f6 Server messages localization using Qt's l10n subsystem:
unc0rr
parents: 8372
diff changeset
    49
    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
    50
        else
8401
87410ae372f6 Server messages localization using Qt's l10n subsystem:
unc0rr
parents: 8372
diff changeset
    51
        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
    52
            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
    53
            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
    54
                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
    55
                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
    56
                [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
    57
    where
5090
2922455e606e Use readInt_
unc0rr
parents: 5030
diff changeset
    58
        parsedProto = readInt_ protoNum
1841
fba7210b438b Retrieve client password from web database and ask for it
unc0rr
parents: 1834
diff changeset
    59
3536
7d99655130ff Partially reimplement joining rooms
unc0rr
parents: 3500
diff changeset
    60
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
    61
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
    62
    (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
    63
    let cl = irnc `client` ci
1879
bb114339eb4e Implement kick from room
unc0rr
parents: 1847
diff changeset
    64
10076
b235e520ea21 Mutual authentication: server side
unc0rr
parents: 8401
diff changeset
    65
    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
    66
        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
    67
        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
    68
        return [ByeClient "Authentication failed"]
1879
bb114339eb4e Implement kick from room
unc0rr
parents: 1847
diff changeset
    69
1804
4e78ad846fb6 New game server:
unc0rr
parents:
diff changeset
    70
10076
b235e520ea21 Mutual authentication: server side
unc0rr
parents: 8401
diff changeset
    71
handleCmd_NotEntered ["PASSWORD", passwd, clientSalt] = do
b235e520ea21 Mutual authentication: server side
unc0rr
parents: 8401
diff changeset
    72
    (ci, irnc) <- ask
b235e520ea21 Mutual authentication: server side
unc0rr
parents: 8401
diff changeset
    73
    let cl = irnc `client` ci
b235e520ea21 Mutual authentication: server side
unc0rr
parents: 8401
diff changeset
    74
b235e520ea21 Mutual authentication: server side
unc0rr
parents: 8401
diff changeset
    75
    let clientHash = h [clientSalt, serverSalt cl, webPassword cl, showB $ clientProto cl, "!hedgewars"]
b235e520ea21 Mutual authentication: server side
unc0rr
parents: 8401
diff changeset
    76
    let serverHash = h [serverSalt cl, clientSalt, webPassword cl, showB $ clientProto cl, "!hedgewars"]
b235e520ea21 Mutual authentication: server side
unc0rr
parents: 8401
diff changeset
    77
b235e520ea21 Mutual authentication: server side
unc0rr
parents: 8401
diff changeset
    78
    if passwd == clientHash then
10077
ca67740f19b2 ADMIN_ACCESS is deprecated long ago
unc0rr
parents: 10076
diff changeset
    79
        return [
10076
b235e520ea21 Mutual authentication: server side
unc0rr
parents: 8401
diff changeset
    80
            AnswerClients [sendChan cl] ["SERVER_AUTH", serverHash] 
10077
ca67740f19b2 ADMIN_ACCESS is deprecated long ago
unc0rr
parents: 10076
diff changeset
    81
            , JoinLobby
ca67740f19b2 ADMIN_ACCESS is deprecated long ago
unc0rr
parents: 10076
diff changeset
    82
            ]
10076
b235e520ea21 Mutual authentication: server side
unc0rr
parents: 8401
diff changeset
    83
        else
b235e520ea21 Mutual authentication: server side
unc0rr
parents: 8401
diff changeset
    84
        return [ByeClient "Authentication failed"]
b235e520ea21 Mutual authentication: server side
unc0rr
parents: 8401
diff changeset
    85
    where
b235e520ea21 Mutual authentication: server side
unc0rr
parents: 8401
diff changeset
    86
        h = B.pack . showDigest . sha1 . BL.fromChunks
b235e520ea21 Mutual authentication: server side
unc0rr
parents: 8401
diff changeset
    87
8372
3c193ec03e09 Logon procedure for checkers, introduce invisible clients
unc0rr
parents: 8371
diff changeset
    88
#if defined(OFFICIAL_SERVER)
8371
0551b5c3de9a - Start work on checker
unc0rr
parents: 5090
diff changeset
    89
handleCmd_NotEntered ["CHECKER", protoNum, newNick, password] = do
0551b5c3de9a - Start work on checker
unc0rr
parents: 5090
diff changeset
    90
    (ci, irnc) <- ask
0551b5c3de9a - Start work on checker
unc0rr
parents: 5090
diff changeset
    91
    let cl = irnc `client` ci
0551b5c3de9a - Start work on checker
unc0rr
parents: 5090
diff changeset
    92
8401
87410ae372f6 Server messages localization using Qt's l10n subsystem:
unc0rr
parents: 8372
diff changeset
    93
    if parsedProto == 0 then return [ProtocolError $ loc "Bad number"]
8371
0551b5c3de9a - Start work on checker
unc0rr
parents: 5090
diff changeset
    94
        else
0551b5c3de9a - Start work on checker
unc0rr
parents: 5090
diff changeset
    95
        return $ [
0551b5c3de9a - Start work on checker
unc0rr
parents: 5090
diff changeset
    96
            ModifyClient (\c -> c{clientProto = parsedProto, nick = newNick, webPassword = password, isChecker = True})
0551b5c3de9a - Start work on checker
unc0rr
parents: 5090
diff changeset
    97
            , CheckRegistered]
0551b5c3de9a - Start work on checker
unc0rr
parents: 5090
diff changeset
    98
    where
0551b5c3de9a - Start work on checker
unc0rr
parents: 5090
diff changeset
    99
        parsedProto = readInt_ protoNum
8372
3c193ec03e09 Logon procedure for checkers, introduce invisible clients
unc0rr
parents: 8371
diff changeset
   100
#endif
8371
0551b5c3de9a - Start work on checker
unc0rr
parents: 5090
diff changeset
   101
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
   102
handleCmd_NotEntered _ = return [ProtocolError "Incorrect command (state: not entered)"]