gameServer/NetRoutines.hs
author Wuzzy <Wuzzy2@mail.ru>
Mon, 06 Aug 2018 19:05:08 +0200
changeset 13611 65a10215ba43
parent 11855 ad435d95ca4b
permissions -rw-r--r--
Fix hog turning around when blowtorching through wrap world edge
Ignore whitespace changes - Everywhere: Within whitespace: At end of lines:
10460
8dcea9087d75 Added copyrights to gameServer directory
Gianfranco Costamagna <costamagnagianfranco@yahoo.it>
parents: 10093
diff changeset
     1
{-
8dcea9087d75 Added copyrights to gameServer directory
Gianfranco Costamagna <costamagnagianfranco@yahoo.it>
parents: 10093
diff changeset
     2
 * Hedgewars, a free turn based strategy game
11046
47a8c19ecb60 more copyright fixes
sheepluva
parents: 10912
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: 10093
diff changeset
     4
 *
8dcea9087d75 Added copyrights to gameServer directory
Gianfranco Costamagna <costamagnagianfranco@yahoo.it>
parents: 10093
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: 10093
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: 10093
diff changeset
     7
 * the Free Software Foundation; version 2 of the License
8dcea9087d75 Added copyrights to gameServer directory
Gianfranco Costamagna <costamagnagianfranco@yahoo.it>
parents: 10093
diff changeset
     8
 *
8dcea9087d75 Added copyrights to gameServer directory
Gianfranco Costamagna <costamagnagianfranco@yahoo.it>
parents: 10093
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: 10093
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: 10093
diff changeset
    11
 * MERCHANTABILITY or FITNESS FOR A PARTICULAR PURPOSE.  See the
8dcea9087d75 Added copyrights to gameServer directory
Gianfranco Costamagna <costamagnagianfranco@yahoo.it>
parents: 10093
diff changeset
    12
 * GNU General Public License for more details.
8dcea9087d75 Added copyrights to gameServer directory
Gianfranco Costamagna <costamagnagianfranco@yahoo.it>
parents: 10093
diff changeset
    13
 *
8dcea9087d75 Added copyrights to gameServer directory
Gianfranco Costamagna <costamagnagianfranco@yahoo.it>
parents: 10093
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: 10093
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: 10093
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: 10093
diff changeset
    17
 \-}
8dcea9087d75 Added copyrights to gameServer directory
Gianfranco Costamagna <costamagnagianfranco@yahoo.it>
parents: 10093
diff changeset
    18
4905
7842d085acf4 Fix merge :D
unc0rr
parents: 4568
diff changeset
    19
{-# LANGUAGE ScopedTypeVariables, OverloadedStrings #-}
1804
4e78ad846fb6 New game server:
unc0rr
parents:
diff changeset
    20
module NetRoutines where
4e78ad846fb6 New game server:
unc0rr
parents:
diff changeset
    21
4e78ad846fb6 New game server:
unc0rr
parents:
diff changeset
    22
import Network.Socket
4e78ad846fb6 New game server:
unc0rr
parents:
diff changeset
    23
import Control.Concurrent.Chan
4e78ad846fb6 New game server:
unc0rr
parents:
diff changeset
    24
import Data.Time
4905
7842d085acf4 Fix merge :D
unc0rr
parents: 4568
diff changeset
    25
import Control.Monad
4918
c6d3aec73f93 Add Unique field to Client structure, and use it to check for matching recieved account status with client
unc0rr
parents: 4905
diff changeset
    26
import Data.Unique
10076
b235e520ea21 Mutual authentication: server side
unc0rr
parents: 9528
diff changeset
    27
import qualified Codec.Binary.Base64 as Base64
b235e520ea21 Mutual authentication: server side
unc0rr
parents: 9528
diff changeset
    28
import qualified Control.Exception as E
b235e520ea21 Mutual authentication: server side
unc0rr
parents: 9528
diff changeset
    29
import System.Entropy
1804
4e78ad846fb6 New game server:
unc0rr
parents:
diff changeset
    30
-----------------------------
4e78ad846fb6 New game server:
unc0rr
parents:
diff changeset
    31
import CoreTypes
1917
c94045b70142 - Better ip2string implementation
unc0rr
parents: 1847
diff changeset
    32
import Utils
10076
b235e520ea21 Mutual authentication: server side
unc0rr
parents: 9528
diff changeset
    33
1804
4e78ad846fb6 New game server:
unc0rr
parents:
diff changeset
    34
4905
7842d085acf4 Fix merge :D
unc0rr
parents: 4568
diff changeset
    35
acceptLoop :: Socket -> Chan CoreMessage -> IO ()
10912
5b8d8ecef5a8 Catch exceptions in accept() call
unc0rr
parents: 10460
diff changeset
    36
acceptLoop servSock chan = E.bracket openHandle closeHandle (forever . f)
10076
b235e520ea21 Mutual authentication: server side
unc0rr
parents: 9528
diff changeset
    37
    where
10912
5b8d8ecef5a8 Catch exceptions in accept() call
unc0rr
parents: 10460
diff changeset
    38
    f ch = E.try (Network.Socket.accept servSock) >>= \v -> case v of
5b8d8ecef5a8 Catch exceptions in accept() call
unc0rr
parents: 10460
diff changeset
    39
      Left (e :: E.IOException) -> return ()
5b8d8ecef5a8 Catch exceptions in accept() call
unc0rr
parents: 10460
diff changeset
    40
      Right (sock, sockAddr) -> do
2867
9be6693c78cb - Unbreak support for client versions prior to 0.9.13-dev
unc0rr
parents: 2403
diff changeset
    41
        clientHost <- sockAddr2String sockAddr
1804
4e78ad846fb6 New game server:
unc0rr
parents:
diff changeset
    42
2867
9be6693c78cb - Unbreak support for client versions prior to 0.9.13-dev
unc0rr
parents: 2403
diff changeset
    43
        currentTime <- getCurrentTime
4905
7842d085acf4 Fix merge :D
unc0rr
parents: 4568
diff changeset
    44
7842d085acf4 Fix merge :D
unc0rr
parents: 4568
diff changeset
    45
        sendChan' <- newChan
1804
4e78ad846fb6 New game server:
unc0rr
parents:
diff changeset
    46
4918
c6d3aec73f93 Add Unique field to Client structure, and use it to check for matching recieved account status with client
unc0rr
parents: 4905
diff changeset
    47
        uid <- newUnique
11855
ad435d95ca4b - Use sandi instead of dataenc (bugs.debian.org/836686)
unc0rr
parents: 11556
diff changeset
    48
        salt <- liftM Base64.encode $ hGetEntropy ch 18
4918
c6d3aec73f93 Add Unique field to Client structure, and use it to check for matching recieved account status with client
unc0rr
parents: 4905
diff changeset
    49
2867
9be6693c78cb - Unbreak support for client versions prior to 0.9.13-dev
unc0rr
parents: 2403
diff changeset
    50
        let newClient =
9be6693c78cb - Unbreak support for client versions prior to 0.9.13-dev
unc0rr
parents: 2403
diff changeset
    51
                (ClientInfo
4918
c6d3aec73f93 Add Unique field to Client structure, and use it to check for matching recieved account status with client
unc0rr
parents: 4905
diff changeset
    52
                    uid
4905
7842d085acf4 Fix merge :D
unc0rr
parents: 4568
diff changeset
    53
                    sendChan'
7842d085acf4 Fix merge :D
unc0rr
parents: 4568
diff changeset
    54
                    sock
2867
9be6693c78cb - Unbreak support for client versions prior to 0.9.13-dev
unc0rr
parents: 2403
diff changeset
    55
                    clientHost
9be6693c78cb - Unbreak support for client versions prior to 0.9.13-dev
unc0rr
parents: 2403
diff changeset
    56
                    currentTime
9be6693c78cb - Unbreak support for client versions prior to 0.9.13-dev
unc0rr
parents: 2403
diff changeset
    57
                    ""
9be6693c78cb - Unbreak support for client versions prior to 0.9.13-dev
unc0rr
parents: 2403
diff changeset
    58
                    ""
10076
b235e520ea21 Mutual authentication: server side
unc0rr
parents: 9528
diff changeset
    59
                    salt
2867
9be6693c78cb - Unbreak support for client versions prior to 0.9.13-dev
unc0rr
parents: 2403
diff changeset
    60
                    False
8372
3c193ec03e09 Logon procedure for checkers, introduce invisible clients
unc0rr
parents: 8371
diff changeset
    61
                    False
2867
9be6693c78cb - Unbreak support for client versions prior to 0.9.13-dev
unc0rr
parents: 2403
diff changeset
    62
                    0
9be6693c78cb - Unbreak support for client versions prior to 0.9.13-dev
unc0rr
parents: 2403
diff changeset
    63
                    0
9be6693c78cb - Unbreak support for client versions prior to 0.9.13-dev
unc0rr
parents: 2403
diff changeset
    64
                    False
9be6693c78cb - Unbreak support for client versions prior to 0.9.13-dev
unc0rr
parents: 2403
diff changeset
    65
                    False
9be6693c78cb - Unbreak support for client versions prior to 0.9.13-dev
unc0rr
parents: 2403
diff changeset
    66
                    False
7757
c20e6c80e249 Don't accept ROUNDFINISHED message twice. Fixes game hangs when half of teams quit game.
unc0rr
parents: 5209
diff changeset
    67
                    False
8245
d1a830c304c7 Change room name if room admin is kicked
unc0rr
parents: 7766
diff changeset
    68
                    False
8371
0551b5c3de9a - Start work on checker
unc0rr
parents: 8245
diff changeset
    69
                    False
9109
878f06e9c484 - Fix issue 521 by resending FULLMAPCONFIG on game finish to those who joined mid-game. Semitested.
unc0rr
parents: 8897
diff changeset
    70
                    False
9435
59eec19cb31a 'c' flag for contributors
unc0rr
parents: 9109
diff changeset
    71
                    False
11464
a9957113404a Allow only one query per session
unc0rr
parents: 11046
diff changeset
    72
                    False
11467
f2c36df8c7b1 Allow server admins to join passworded/restricted rooms when it is really needed
unc0rr
parents: 11466
diff changeset
    73
                    False
4986
33fe91b2bcbf Use Maybe for storing client's clan, allows less error-prone spectator checks
unc0rr
parents: 4932
diff changeset
    74
                    Nothing
8507
f4475782cf45 Some more work on checker
unc0rr
parents: 8372
diff changeset
    75
                    Nothing
10093
ada172d33988 More work on flood detector
unc0rr
parents: 10078
diff changeset
    76
                    newEventsInfo
ada172d33988 More work on flood detector
unc0rr
parents: 10078
diff changeset
    77
                    newEventsInfo
ada172d33988 More work on flood detector
unc0rr
parents: 10078
diff changeset
    78
                    newEventsInfo
4987
cf9470964dba Use 'undefined' less (replace with default values and 'error')
unc0rr
parents: 4986
diff changeset
    79
                    0
11466
4b5c7a5c49fd Defer kicking to the time when everything is in consistent state
unc0rr
parents: 11464
diff changeset
    80
                    []
11556
af9aa8d5863c Filter out hog speech messages with non-local team index (not tested)
unc0rr
parents: 11467
diff changeset
    81
                    []
2867
9be6693c78cb - Unbreak support for client versions prior to 0.9.13-dev
unc0rr
parents: 2403
diff changeset
    82
                    )
1804
4e78ad846fb6 New game server:
unc0rr
parents:
diff changeset
    83
4905
7842d085acf4 Fix merge :D
unc0rr
parents: 4568
diff changeset
    84
        writeChan chan $ Accept newClient
2867
9be6693c78cb - Unbreak support for client versions prior to 0.9.13-dev
unc0rr
parents: 2403
diff changeset
    85
        return ()