gameServer/NetRoutines.hs
author unc0rr
Wed, 18 Feb 2009 15:04:40 +0000
changeset 1804 4e78ad846fb6
child 1839 5dd4cb7fd7e5
permissions -rw-r--r--
New game server: - Incomplete implementation - More robust, no memory leaks, better architecture for easy features addition - Incompatible with current client
Ignore whitespace changes - Everywhere: Within whitespace: At end of lines:
1804
4e78ad846fb6 New game server:
unc0rr
parents:
diff changeset
     1
{-# LANGUAGE PatternSignatures #-}
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
4e78ad846fb6 New game server:
unc0rr
parents:
diff changeset
    10
import Control.Exception
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
4e78ad846fb6 New game server:
unc0rr
parents:
diff changeset
    15
4e78ad846fb6 New game server:
unc0rr
parents:
diff changeset
    16
sockAddr2String :: SockAddr -> IO String
4e78ad846fb6 New game server:
unc0rr
parents:
diff changeset
    17
sockAddr2String (SockAddrInet _ hostAddr) = inet_ntoa hostAddr
4e78ad846fb6 New game server:
unc0rr
parents:
diff changeset
    18
sockAddr2String (SockAddrInet6 _ _ (a, b, c, d) _) = return (foldr1 (\a b -> a ++ ":" ++ b) [show a, show b, show c, show d])
4e78ad846fb6 New game server:
unc0rr
parents:
diff changeset
    19
4e78ad846fb6 New game server:
unc0rr
parents:
diff changeset
    20
acceptLoop :: Socket -> Chan CoreMessage -> Int -> IO ()
4e78ad846fb6 New game server:
unc0rr
parents:
diff changeset
    21
acceptLoop servSock coreChan clientCounter = do
4e78ad846fb6 New game server:
unc0rr
parents:
diff changeset
    22
	Control.Exception.handle
4e78ad846fb6 New game server:
unc0rr
parents:
diff changeset
    23
		(\(_ :: Exception) -> putStrLn "exception on connect") $
4e78ad846fb6 New game server:
unc0rr
parents:
diff changeset
    24
		do
4e78ad846fb6 New game server:
unc0rr
parents:
diff changeset
    25
		(socket, sockAddr) <- Network.Socket.accept servSock
4e78ad846fb6 New game server:
unc0rr
parents:
diff changeset
    26
4e78ad846fb6 New game server:
unc0rr
parents:
diff changeset
    27
		cHandle <- socketToHandle socket ReadWriteMode
4e78ad846fb6 New game server:
unc0rr
parents:
diff changeset
    28
		hSetBuffering cHandle LineBuffering
4e78ad846fb6 New game server:
unc0rr
parents:
diff changeset
    29
		clientHost <- sockAddr2String sockAddr
4e78ad846fb6 New game server:
unc0rr
parents:
diff changeset
    30
4e78ad846fb6 New game server:
unc0rr
parents:
diff changeset
    31
		currentTime <- getCurrentTime
4e78ad846fb6 New game server:
unc0rr
parents:
diff changeset
    32
		putStrLn $ (show currentTime) ++ " new client id: " ++ (show nextID)
4e78ad846fb6 New game server:
unc0rr
parents:
diff changeset
    33
		
4e78ad846fb6 New game server:
unc0rr
parents:
diff changeset
    34
		sendChan <- newChan
4e78ad846fb6 New game server:
unc0rr
parents:
diff changeset
    35
4e78ad846fb6 New game server:
unc0rr
parents:
diff changeset
    36
		let newClient =
4e78ad846fb6 New game server:
unc0rr
parents:
diff changeset
    37
				(ClientInfo
4e78ad846fb6 New game server:
unc0rr
parents:
diff changeset
    38
					nextID
4e78ad846fb6 New game server:
unc0rr
parents:
diff changeset
    39
					sendChan
4e78ad846fb6 New game server:
unc0rr
parents:
diff changeset
    40
					cHandle
4e78ad846fb6 New game server:
unc0rr
parents:
diff changeset
    41
					clientHost
4e78ad846fb6 New game server:
unc0rr
parents:
diff changeset
    42
					--currentTime
4e78ad846fb6 New game server:
unc0rr
parents:
diff changeset
    43
					""
4e78ad846fb6 New game server:
unc0rr
parents:
diff changeset
    44
					0
4e78ad846fb6 New game server:
unc0rr
parents:
diff changeset
    45
					0
4e78ad846fb6 New game server:
unc0rr
parents:
diff changeset
    46
					False
4e78ad846fb6 New game server:
unc0rr
parents:
diff changeset
    47
					False
4e78ad846fb6 New game server:
unc0rr
parents:
diff changeset
    48
					False
4e78ad846fb6 New game server:
unc0rr
parents:
diff changeset
    49
					False)
4e78ad846fb6 New game server:
unc0rr
parents:
diff changeset
    50
4e78ad846fb6 New game server:
unc0rr
parents:
diff changeset
    51
		writeChan coreChan $ Accept newClient
4e78ad846fb6 New game server:
unc0rr
parents:
diff changeset
    52
4e78ad846fb6 New game server:
unc0rr
parents:
diff changeset
    53
		forkIO $ clientRecvLoop cHandle coreChan nextID
4e78ad846fb6 New game server:
unc0rr
parents:
diff changeset
    54
		forkIO $ clientSendLoop cHandle coreChan sendChan nextID
4e78ad846fb6 New game server:
unc0rr
parents:
diff changeset
    55
		return ()
4e78ad846fb6 New game server:
unc0rr
parents:
diff changeset
    56
4e78ad846fb6 New game server:
unc0rr
parents:
diff changeset
    57
	yield -- hm?
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