gameServer/NetRoutines.hs
author nemo
Sun, 24 Jan 2010 16:46:06 +0000
changeset 2712 8f4527c9137c
parent 2403 6c5d504af2ba
child 2867 9be6693c78cb
permissions -rw-r--r--
Minor tweak, try to make long flavour text last longer, move the hurt self messages to unused messages group, so they don't get wiped by crate an instant later.
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