gameServer/NetRoutines.hs
author unc0rr
Wed, 18 Mar 2009 15:48:43 +0000
changeset 1899 5763f46d7486
parent 1847 2178c0fc838c
child 1917 c94045b70142
permissions -rw-r--r--
Sync schemes config over net should work now (untested)

{-# LANGUAGE PatternSignatures #-}
module NetRoutines where

import Network
import Network.Socket
import System.IO
import Control.Concurrent
import Control.Concurrent.Chan
import Control.Concurrent.STM
import Control.Exception
import Data.Time
-----------------------------
import CoreTypes
import ClientIO

sockAddr2String :: SockAddr -> IO String
sockAddr2String (SockAddrInet _ hostAddr) = inet_ntoa hostAddr
sockAddr2String (SockAddrInet6 _ _ (a, b, c, d) _) = return (foldr1 (\a b -> a ++ ":" ++ b) [show a, show b, show c, show d])

acceptLoop :: Socket -> Chan CoreMessage -> Int -> IO ()
acceptLoop servSock coreChan clientCounter = do
	Control.Exception.handle
		(\(_ :: Exception) -> putStrLn "exception on connect") $
		do
		(socket, sockAddr) <- Network.Socket.accept servSock

		cHandle <- socketToHandle socket ReadWriteMode
		hSetBuffering cHandle LineBuffering
		clientHost <- sockAddr2String sockAddr

		currentTime <- getCurrentTime
		--putStrLn $ (show currentTime) ++ " new client id: " ++ (show nextID)
		
		sendChan <- newChan

		let newClient =
				(ClientInfo
					nextID
					sendChan
					cHandle
					clientHost
					--currentTime
					""
					""
					False
					0
					0
					False
					False
					False
					False
					False
					)

		writeChan coreChan $ Accept newClient

		forkIO $ clientRecvLoop cHandle coreChan nextID
		forkIO $ clientSendLoop cHandle coreChan sendChan nextID
		return ()

	yield -- hm?
	acceptLoop servSock coreChan nextID
	where
		nextID = clientCounter + 1