gameServer/NetRoutines.hs
author mbait
Wed, 10 Feb 2010 09:43:59 +0000
branchmbait-mangen
changeset 2561 3038a1a52195
parent 2403 6c5d504af2ba
child 2867 9be6693c78cb
permissions -rw-r--r--
change trunk branch to 0.9.12 branch
Ignore whitespace changes - Everywhere: Within whitespace: At end of lines:
2348
b39d826e1ccd Drop support for ghc 6.8, use 6.10 instead
unc0rr
parents: 2296
diff changeset
     1
{-# LANGUAGE ScopedTypeVariables #-}
1804
4e78ad846fb6 New game server:
unc0rr
parents:
diff changeset
     2
module NetRoutines where
4e78ad846fb6 New game server:
unc0rr
parents:
diff changeset
     3
4e78ad846fb6 New game server:
unc0rr
parents:
diff changeset
     4
import Network
4e78ad846fb6 New game server:
unc0rr
parents:
diff changeset
     5
import Network.Socket
4e78ad846fb6 New game server:
unc0rr
parents:
diff changeset
     6
import System.IO
4e78ad846fb6 New game server:
unc0rr
parents:
diff changeset
     7
import Control.Concurrent
4e78ad846fb6 New game server:
unc0rr
parents:
diff changeset
     8
import Control.Concurrent.Chan
4e78ad846fb6 New game server:
unc0rr
parents:
diff changeset
     9
import Control.Concurrent.STM
2296
19f2f76dc346 Patch for compiling with 6.10 (define NEW_EXCEPTIONS to do that)
unc0rr
parents: 2245
diff changeset
    10
import qualified Control.Exception as Exception
1804
4e78ad846fb6 New game server:
unc0rr
parents:
diff changeset
    11
import Data.Time
4e78ad846fb6 New game server:
unc0rr
parents:
diff changeset
    12
-----------------------------
4e78ad846fb6 New game server:
unc0rr
parents:
diff changeset
    13
import CoreTypes
4e78ad846fb6 New game server:
unc0rr
parents:
diff changeset
    14
import ClientIO
1917
c94045b70142 - Better ip2string implementation
unc0rr
parents: 1847
diff changeset
    15
import Utils
1804
4e78ad846fb6 New game server:
unc0rr
parents:
diff changeset
    16
4e78ad846fb6 New game server:
unc0rr
parents:
diff changeset
    17
acceptLoop :: Socket -> Chan CoreMessage -> Int -> IO ()
4e78ad846fb6 New game server:
unc0rr
parents:
diff changeset
    18
acceptLoop servSock coreChan clientCounter = do
2296
19f2f76dc346 Patch for compiling with 6.10 (define NEW_EXCEPTIONS to do that)
unc0rr
parents: 2245
diff changeset
    19
	Exception.handle
2348
b39d826e1ccd Drop support for ghc 6.8, use 6.10 instead
unc0rr
parents: 2296
diff changeset
    20
		(\(_ :: Exception.IOException) -> putStrLn "exception on connect") $
1804
4e78ad846fb6 New game server:
unc0rr
parents:
diff changeset
    21
		do
4e78ad846fb6 New game server:
unc0rr
parents:
diff changeset
    22
		(socket, sockAddr) <- Network.Socket.accept servSock
4e78ad846fb6 New game server:
unc0rr
parents:
diff changeset
    23
4e78ad846fb6 New game server:
unc0rr
parents:
diff changeset
    24
		cHandle <- socketToHandle socket ReadWriteMode
4e78ad846fb6 New game server:
unc0rr
parents:
diff changeset
    25
		hSetBuffering cHandle LineBuffering
4e78ad846fb6 New game server:
unc0rr
parents:
diff changeset
    26
		clientHost <- sockAddr2String sockAddr
4e78ad846fb6 New game server:
unc0rr
parents:
diff changeset
    27
4e78ad846fb6 New game server:
unc0rr
parents:
diff changeset
    28
		currentTime <- getCurrentTime
4e78ad846fb6 New game server:
unc0rr
parents:
diff changeset
    29
		
4e78ad846fb6 New game server:
unc0rr
parents:
diff changeset
    30
		sendChan <- newChan
4e78ad846fb6 New game server:
unc0rr
parents:
diff changeset
    31
4e78ad846fb6 New game server:
unc0rr
parents:
diff changeset
    32
		let newClient =
4e78ad846fb6 New game server:
unc0rr
parents:
diff changeset
    33
				(ClientInfo
4e78ad846fb6 New game server:
unc0rr
parents:
diff changeset
    34
					nextID
4e78ad846fb6 New game server:
unc0rr
parents:
diff changeset
    35
					sendChan
4e78ad846fb6 New game server:
unc0rr
parents:
diff changeset
    36
					cHandle
4e78ad846fb6 New game server:
unc0rr
parents:
diff changeset
    37
					clientHost
1926
cb46fbdcaa41 Add simple DoS protection mechanism (although better than previous server had)
unc0rr
parents: 1924
diff changeset
    38
					currentTime
1804
4e78ad846fb6 New game server:
unc0rr
parents:
diff changeset
    39
					""
1841
fba7210b438b Retrieve client password from web database and ask for it
unc0rr
parents: 1839
diff changeset
    40
					""
fba7210b438b Retrieve client password from web database and ask for it
unc0rr
parents: 1839
diff changeset
    41
					False
1804
4e78ad846fb6 New game server:
unc0rr
parents:
diff changeset
    42
					0
4e78ad846fb6 New game server:
unc0rr
parents:
diff changeset
    43
					0
1927
e2031906a347 Ping clients every 30 seconds. Disconnection due to ping timeout to be implemented.
unc0rr
parents: 1926
diff changeset
    44
					0
1804
4e78ad846fb6 New game server:
unc0rr
parents:
diff changeset
    45
					False
4e78ad846fb6 New game server:
unc0rr
parents:
diff changeset
    46
					False
4e78ad846fb6 New game server:
unc0rr
parents:
diff changeset
    47
					False
2245
c011aecc95e5 unc0rr's patch from issue #144 - prevent spectators from ruining the game
nemo
parents: 2004
diff changeset
    48
					undefined
2403
6c5d504af2ba - Proper /team command implementation
unc0rr
parents: 2348
diff changeset
    49
					undefined
1847
2178c0fc838c Set admin flag and send admin notification to users with rid equal to 3
unc0rr
parents: 1841
diff changeset
    50
					)
1804
4e78ad846fb6 New game server:
unc0rr
parents:
diff changeset
    51
4e78ad846fb6 New game server:
unc0rr
parents:
diff changeset
    52
		writeChan coreChan $ Accept newClient
4e78ad846fb6 New game server:
unc0rr
parents:
diff changeset
    53
4e78ad846fb6 New game server:
unc0rr
parents:
diff changeset
    54
		forkIO $ clientRecvLoop cHandle coreChan nextID
4e78ad846fb6 New game server:
unc0rr
parents:
diff changeset
    55
		forkIO $ clientSendLoop cHandle coreChan sendChan nextID
4e78ad846fb6 New game server:
unc0rr
parents:
diff changeset
    56
		return ()
4e78ad846fb6 New game server:
unc0rr
parents:
diff changeset
    57
4e78ad846fb6 New game server:
unc0rr
parents:
diff changeset
    58
	acceptLoop servSock coreChan nextID
4e78ad846fb6 New game server:
unc0rr
parents:
diff changeset
    59
	where
4e78ad846fb6 New game server:
unc0rr
parents:
diff changeset
    60
		nextID = clientCounter + 1