gameServer/NetRoutines.hs
author sheepluva
Sun, 15 Nov 2015 13:34:32 +0100
branchsdl2transition
changeset 11382 43ad1122a368
parent 11046 47a8c19ecb60
child 11464 a9957113404a
permissions -rw-r--r--
closing sdl2transition branch, because it will be merged
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 Data.ByteString as BW
b235e520ea21 Mutual authentication: server side
unc0rr
parents: 9528
diff changeset
    29
import qualified Data.ByteString.Char8 as B
b235e520ea21 Mutual authentication: server side
unc0rr
parents: 9528
diff changeset
    30
import qualified Control.Exception as E
b235e520ea21 Mutual authentication: server side
unc0rr
parents: 9528
diff changeset
    31
import System.Entropy
10912
5b8d8ecef5a8 Catch exceptions in accept() call
unc0rr
parents: 10460
diff changeset
    32
import Data.Either
1804
4e78ad846fb6 New game server:
unc0rr
parents:
diff changeset
    33
-----------------------------
4e78ad846fb6 New game server:
unc0rr
parents:
diff changeset
    34
import CoreTypes
1917
c94045b70142 - Better ip2string implementation
unc0rr
parents: 1847
diff changeset
    35
import Utils
10076
b235e520ea21 Mutual authentication: server side
unc0rr
parents: 9528
diff changeset
    36
1804
4e78ad846fb6 New game server:
unc0rr
parents:
diff changeset
    37
4905
7842d085acf4 Fix merge :D
unc0rr
parents: 4568
diff changeset
    38
acceptLoop :: Socket -> Chan CoreMessage -> IO ()
10912
5b8d8ecef5a8 Catch exceptions in accept() call
unc0rr
parents: 10460
diff changeset
    39
acceptLoop servSock chan = E.bracket openHandle closeHandle (forever . f)
10076
b235e520ea21 Mutual authentication: server side
unc0rr
parents: 9528
diff changeset
    40
    where
10912
5b8d8ecef5a8 Catch exceptions in accept() call
unc0rr
parents: 10460
diff changeset
    41
    f ch = E.try (Network.Socket.accept servSock) >>= \v -> case v of
5b8d8ecef5a8 Catch exceptions in accept() call
unc0rr
parents: 10460
diff changeset
    42
      Left (e :: E.IOException) -> return ()
5b8d8ecef5a8 Catch exceptions in accept() call
unc0rr
parents: 10460
diff changeset
    43
      Right (sock, sockAddr) -> do
2867
9be6693c78cb - Unbreak support for client versions prior to 0.9.13-dev
unc0rr
parents: 2403
diff changeset
    44
        clientHost <- sockAddr2String sockAddr
1804
4e78ad846fb6 New game server:
unc0rr
parents:
diff changeset
    45
2867
9be6693c78cb - Unbreak support for client versions prior to 0.9.13-dev
unc0rr
parents: 2403
diff changeset
    46
        currentTime <- getCurrentTime
4905
7842d085acf4 Fix merge :D
unc0rr
parents: 4568
diff changeset
    47
7842d085acf4 Fix merge :D
unc0rr
parents: 4568
diff changeset
    48
        sendChan' <- newChan
1804
4e78ad846fb6 New game server:
unc0rr
parents:
diff changeset
    49
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
    50
        uid <- newUnique
10078
8572d1f8b2f0 Some love to pas2c
unc0rr
parents: 10076
diff changeset
    51
        salt <- liftM (B.pack . Base64.encode . BW.unpack) $ 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
    52
2867
9be6693c78cb - Unbreak support for client versions prior to 0.9.13-dev
unc0rr
parents: 2403
diff changeset
    53
        let newClient =
9be6693c78cb - Unbreak support for client versions prior to 0.9.13-dev
unc0rr
parents: 2403
diff changeset
    54
                (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
    55
                    uid
4905
7842d085acf4 Fix merge :D
unc0rr
parents: 4568
diff changeset
    56
                    sendChan'
7842d085acf4 Fix merge :D
unc0rr
parents: 4568
diff changeset
    57
                    sock
2867
9be6693c78cb - Unbreak support for client versions prior to 0.9.13-dev
unc0rr
parents: 2403
diff changeset
    58
                    clientHost
9be6693c78cb - Unbreak support for client versions prior to 0.9.13-dev
unc0rr
parents: 2403
diff changeset
    59
                    currentTime
9be6693c78cb - Unbreak support for client versions prior to 0.9.13-dev
unc0rr
parents: 2403
diff changeset
    60
                    ""
9be6693c78cb - Unbreak support for client versions prior to 0.9.13-dev
unc0rr
parents: 2403
diff changeset
    61
                    ""
10076
b235e520ea21 Mutual authentication: server side
unc0rr
parents: 9528
diff changeset
    62
                    salt
2867
9be6693c78cb - Unbreak support for client versions prior to 0.9.13-dev
unc0rr
parents: 2403
diff changeset
    63
                    False
8372
3c193ec03e09 Logon procedure for checkers, introduce invisible clients
unc0rr
parents: 8371
diff changeset
    64
                    False
2867
9be6693c78cb - Unbreak support for client versions prior to 0.9.13-dev
unc0rr
parents: 2403
diff changeset
    65
                    0
9be6693c78cb - Unbreak support for client versions prior to 0.9.13-dev
unc0rr
parents: 2403
diff changeset
    66
                    0
9be6693c78cb - Unbreak support for client versions prior to 0.9.13-dev
unc0rr
parents: 2403
diff changeset
    67
                    False
9be6693c78cb - Unbreak support for client versions prior to 0.9.13-dev
unc0rr
parents: 2403
diff changeset
    68
                    False
9be6693c78cb - Unbreak support for client versions prior to 0.9.13-dev
unc0rr
parents: 2403
diff changeset
    69
                    False
7757
c20e6c80e249 Don't accept ROUNDFINISHED message twice. Fixes game hangs when half of teams quit game.
unc0rr
parents: 5209
diff changeset
    70
                    False
8245
d1a830c304c7 Change room name if room admin is kicked
unc0rr
parents: 7766
diff changeset
    71
                    False
8371
0551b5c3de9a - Start work on checker
unc0rr
parents: 8245
diff changeset
    72
                    False
9109
878f06e9c484 - Fix issue 521 by resending FULLMAPCONFIG on game finish to those who joined mid-game. Semitested.
unc0rr
parents: 8897
diff changeset
    73
                    False
9435
59eec19cb31a 'c' flag for contributors
unc0rr
parents: 9109
diff changeset
    74
                    False
4986
33fe91b2bcbf Use Maybe for storing client's clan, allows less error-prone spectator checks
unc0rr
parents: 4932
diff changeset
    75
                    Nothing
8507
f4475782cf45 Some more work on checker
unc0rr
parents: 8372
diff changeset
    76
                    Nothing
10093
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
ada172d33988 More work on flood detector
unc0rr
parents: 10078
diff changeset
    79
                    newEventsInfo
4987
cf9470964dba Use 'undefined' less (replace with default values and 'error')
unc0rr
parents: 4986
diff changeset
    80
                    0
2867
9be6693c78cb - Unbreak support for client versions prior to 0.9.13-dev
unc0rr
parents: 2403
diff changeset
    81
                    )
1804
4e78ad846fb6 New game server:
unc0rr
parents:
diff changeset
    82
4905
7842d085acf4 Fix merge :D
unc0rr
parents: 4568
diff changeset
    83
        writeChan chan $ Accept newClient
2867
9be6693c78cb - Unbreak support for client versions prior to 0.9.13-dev
unc0rr
parents: 2403
diff changeset
    84
        return ()