gameServer/HWProtoNEState.hs
author Wuzzy <Wuzzy2@mail.ru>
Fri, 12 Jun 2020 00:20:47 +0200
changeset 15640 e21285b7c5e6
parent 13856 acb8b5530aa8
permissions -rw-r--r--
Teach AI to use seduction
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
13081
dce9f0b84a18 Change misleading server error message about nicknames
Wuzzy <Wuzzy2@mail.ru>
parents: 13079
diff changeset
    37
    if not . B.null $ nick cl then return [ProtocolError $ loc "Nickname already provided."]
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
13079
81c154fd4380 More user-friendly server messages
Wuzzy <Wuzzy2@mail.ru>
parents: 11046
diff changeset
    39
        if illegalName newNick then return [ByeClient $ loc "Illegal nickname! Nicknames must be between 1-40 characters long, must not have a trailing or leading space and must not have any of these characters: $()*+?[]^{|}"]
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
13079
81c154fd4380 More user-friendly server messages
Wuzzy <Wuzzy2@mail.ru>
parents: 11046
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
13079
81c154fd4380 More user-friendly server messages
Wuzzy <Wuzzy2@mail.ru>
parents: 11046
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
13673
1aa5e884326a Fix some string/translation inconsistencies in strings related to leaving
Wuzzy <Wuzzy2@mail.ru>
parents: 13081
diff changeset
    68
        -- String is parsed by frontend, do not localize!
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
    69
        return [ByeClient "Authentication failed"]
1879
bb114339eb4e Implement kick from room
unc0rr
parents: 1847
diff changeset
    70
1804
4e78ad846fb6 New game server:
unc0rr
parents:
diff changeset
    71
10076
b235e520ea21 Mutual authentication: server side
unc0rr
parents: 8401
diff changeset
    72
handleCmd_NotEntered ["PASSWORD", passwd, clientSalt] = do
b235e520ea21 Mutual authentication: server side
unc0rr
parents: 8401
diff changeset
    73
    (ci, irnc) <- ask
b235e520ea21 Mutual authentication: server side
unc0rr
parents: 8401
diff changeset
    74
    let cl = irnc `client` ci
b235e520ea21 Mutual authentication: server side
unc0rr
parents: 8401
diff changeset
    75
b235e520ea21 Mutual authentication: server side
unc0rr
parents: 8401
diff changeset
    76
    let clientHash = h [clientSalt, serverSalt cl, webPassword cl, showB $ clientProto cl, "!hedgewars"]
b235e520ea21 Mutual authentication: server side
unc0rr
parents: 8401
diff changeset
    77
    let serverHash = h [serverSalt cl, clientSalt, webPassword cl, showB $ clientProto cl, "!hedgewars"]
b235e520ea21 Mutual authentication: server side
unc0rr
parents: 8401
diff changeset
    78
b235e520ea21 Mutual authentication: server side
unc0rr
parents: 8401
diff changeset
    79
    if passwd == clientHash then
10077
ca67740f19b2 ADMIN_ACCESS is deprecated long ago
unc0rr
parents: 10076
diff changeset
    80
        return [
10076
b235e520ea21 Mutual authentication: server side
unc0rr
parents: 8401
diff changeset
    81
            AnswerClients [sendChan cl] ["SERVER_AUTH", serverHash] 
10077
ca67740f19b2 ADMIN_ACCESS is deprecated long ago
unc0rr
parents: 10076
diff changeset
    82
            , JoinLobby
ca67740f19b2 ADMIN_ACCESS is deprecated long ago
unc0rr
parents: 10076
diff changeset
    83
            ]
10076
b235e520ea21 Mutual authentication: server side
unc0rr
parents: 8401
diff changeset
    84
        else
13673
1aa5e884326a Fix some string/translation inconsistencies in strings related to leaving
Wuzzy <Wuzzy2@mail.ru>
parents: 13081
diff changeset
    85
        -- String is parsed by frontend, do not localize!
10076
b235e520ea21 Mutual authentication: server side
unc0rr
parents: 8401
diff changeset
    86
        return [ByeClient "Authentication failed"]
b235e520ea21 Mutual authentication: server side
unc0rr
parents: 8401
diff changeset
    87
    where
b235e520ea21 Mutual authentication: server side
unc0rr
parents: 8401
diff changeset
    88
        h = B.pack . showDigest . sha1 . BL.fromChunks
b235e520ea21 Mutual authentication: server side
unc0rr
parents: 8401
diff changeset
    89
8372
3c193ec03e09 Logon procedure for checkers, introduce invisible clients
unc0rr
parents: 8371
diff changeset
    90
#if defined(OFFICIAL_SERVER)
8371
0551b5c3de9a - Start work on checker
unc0rr
parents: 5090
diff changeset
    91
handleCmd_NotEntered ["CHECKER", protoNum, newNick, password] = do
0551b5c3de9a - Start work on checker
unc0rr
parents: 5090
diff changeset
    92
    (ci, irnc) <- ask
0551b5c3de9a - Start work on checker
unc0rr
parents: 5090
diff changeset
    93
    let cl = irnc `client` ci
0551b5c3de9a - Start work on checker
unc0rr
parents: 5090
diff changeset
    94
13079
81c154fd4380 More user-friendly server messages
Wuzzy <Wuzzy2@mail.ru>
parents: 11046
diff changeset
    95
    if parsedProto == 0 then return [ProtocolError $ loc "Bad number."]
8371
0551b5c3de9a - Start work on checker
unc0rr
parents: 5090
diff changeset
    96
        else
0551b5c3de9a - Start work on checker
unc0rr
parents: 5090
diff changeset
    97
        return $ [
0551b5c3de9a - Start work on checker
unc0rr
parents: 5090
diff changeset
    98
            ModifyClient (\c -> c{clientProto = parsedProto, nick = newNick, webPassword = password, isChecker = True})
0551b5c3de9a - Start work on checker
unc0rr
parents: 5090
diff changeset
    99
            , CheckRegistered]
0551b5c3de9a - Start work on checker
unc0rr
parents: 5090
diff changeset
   100
    where
0551b5c3de9a - Start work on checker
unc0rr
parents: 5090
diff changeset
   101
        parsedProto = readInt_ protoNum
8372
3c193ec03e09 Logon procedure for checkers, introduce invisible clients
unc0rr
parents: 8371
diff changeset
   102
#endif
8371
0551b5c3de9a - Start work on checker
unc0rr
parents: 5090
diff changeset
   103
13849
07b3dacd00f8 gameServer: Always report command name if getting an incorrect command
Wuzzy <Wuzzy2@mail.ru>
parents: 13673
diff changeset
   104
handleCmd_NotEntered (s:_) = return [ProtocolError $ "Incorrect command '" `B.append` s `B.append` "' (state: not entered)"]
13856
acb8b5530aa8 ..and for logging in handler
alfadur
parents: 13849
diff changeset
   105
acb8b5530aa8 ..and for logging in handler
alfadur
parents: 13849
diff changeset
   106
handleCmd_NotEntered [] = return [ProtocolError "Empty command (state: not entered)"]