# HG changeset patch
# User unc0rr
# Date 1234969480 0
# Node ID 4e78ad846fb6a118b33474e4445051142084f58d
# Parent  95efe37482e3756cbca883f49869ec79ead70e8c
New game server:
 - Incomplete implementation
 - More robust, no memory leaks, better architecture for easy features addition
 - Incompatible with current client

diff -r 95efe37482e3 -r 4e78ad846fb6 gameServer/Actions.hs
--- /dev/null	Thu Jan 01 00:00:00 1970 +0000
+++ b/gameServer/Actions.hs	Wed Feb 18 15:04:40 2009 +0000
@@ -0,0 +1,197 @@
+module Actions where
+
+import Control.Concurrent.STM
+import Control.Concurrent.Chan
+import Data.IntMap
+import qualified Data.IntSet as IntSet
+import Monad
+-----------------------------
+import CoreTypes
+
+data Action =
+	AnswerThisClient [String]
+	| AnswerAll [String]
+	| AnswerAllOthers [String]
+	| AnswerThisRoom [String]
+	| AnswerOthersInRoom [String]
+	| AnswerLobby [String]
+	| RoomAddThisClient Int -- roomID
+	| RoomRemoveThisClient
+	| RemoveRoom
+	| ProtocolError String
+	| Warning String
+	| ByeClient String
+	| ModifyClient (ClientInfo -> ClientInfo)
+	| ModifyRoom (RoomInfo -> RoomInfo)
+	| AddRoom String String
+	| Dump
+
+type CmdHandler = Int -> Clients -> Rooms -> [String] -> [Action]
+
+
+processAction :: (Int, ServerInfo, Clients, Rooms) -> Action -> IO (Int, ServerInfo, Clients, Rooms)
+
+
+processAction (clID, serverInfo, clients, rooms) (AnswerThisClient msg) = do
+	writeChan (sendChan $ clients ! clID) msg
+	return (clID, serverInfo, clients, rooms)
+
+
+processAction (clID, serverInfo, clients, rooms) (AnswerAll msg) = do
+	mapM_ (\id -> writeChan (sendChan $ clients ! id) msg) (keys clients)
+	return (clID, serverInfo, clients, rooms)
+
+
+processAction (clID, serverInfo, clients, rooms) (AnswerAllOthers msg) = do
+	mapM_ (\id -> writeChan (sendChan $ clients ! id) msg) $ Prelude.filter (/= clID) (keys clients)
+	return (clID, serverInfo, clients, rooms)
+
+
+processAction (clID, serverInfo, clients, rooms) (AnswerThisRoom msg) = do
+	mapM_ (\id -> writeChan (sendChan $ clients ! id) msg) roomClients
+	return (clID, serverInfo, clients, rooms)
+	where
+		roomClients = IntSet.elems $ playersIDs room
+		room = rooms ! rID
+		rID = roomID client
+		client = clients ! clID
+
+
+processAction (clID, serverInfo, clients, rooms) (AnswerOthersInRoom msg) = do
+	mapM_ (\id -> writeChan (sendChan $ clients ! id) msg) $ Prelude.filter (/= clID) roomClients
+	return (clID, serverInfo, clients, rooms)
+	where
+		roomClients = IntSet.elems $ playersIDs room
+		room = rooms ! rID
+		rID = roomID client
+		client = clients ! clID
+
+
+processAction (clID, serverInfo, clients, rooms) (AnswerLobby msg) = do
+	mapM_ (\id -> writeChan (sendChan $ clients ! id) msg) roomClients
+	return (clID, serverInfo, clients, rooms)
+	where
+		roomClients = IntSet.elems $ playersIDs room
+		room = rooms ! 0
+
+
+processAction (clID, serverInfo, clients, rooms) (ProtocolError msg) = do
+	writeChan (sendChan $ clients ! clID) ["ERROR", msg]
+	return (clID, serverInfo, clients, rooms)
+
+
+processAction (clID, serverInfo, clients, rooms) (Warning msg) = do
+	writeChan (sendChan $ clients ! clID) ["WARNING", msg]
+	return (clID, serverInfo, clients, rooms)
+
+
+processAction (clID, serverInfo, clients, rooms) (ByeClient msg) = do
+	mapM_ (processAction (clID, serverInfo, clients, rooms)) $ answerOthersQuit ++ answerInformRoom
+	writeChan (sendChan $ clients ! clID) ["BYE"]
+	return (
+			0,
+			serverInfo,
+			delete clID clients,
+			adjust (\r -> r{playersIDs = IntSet.delete clID (playersIDs r), playersIn = (playersIn r) - 1}) rID rooms
+			)
+	where
+		client = clients ! clID
+		rID = roomID client
+		clientNick = nick client
+		answerInformRoom =
+			if roomID client /= 0 then
+				if not $ Prelude.null msg then
+					[AnswerThisRoom ["LEFT", clientNick, msg]]
+				else
+					[AnswerThisRoom ["LEFT", clientNick]]
+			else
+				[]
+		answerOthersQuit =
+			if not $ Prelude.null clientNick then
+				if not $ Prelude.null msg then
+					[AnswerAll ["LOBBY:LEFT", clientNick, msg]]
+				else
+					[AnswerAll ["LOBBY:LEFT", clientNick]]
+			else
+				[]
+
+
+processAction (clID, serverInfo, clients, rooms) (ModifyClient func) = do
+	return (clID, serverInfo, adjust func clID clients, rooms)
+
+
+processAction (clID, serverInfo, clients, rooms) (ModifyRoom func) = do
+	return (clID, serverInfo, clients, adjust func rID rooms)
+	where
+		rID = roomID $ clients ! clID
+
+
+processAction (clID, serverInfo, clients, rooms) (RoomAddThisClient rID) = do
+	processAction (
+		clID,
+		serverInfo,
+		adjust (\cl -> cl{roomID = rID}) clID clients,
+		adjust (\r -> r{playersIDs = IntSet.insert clID (playersIDs r), playersIn = (playersIn r) + 1}) rID $
+			adjust (\r -> r{playersIDs = IntSet.delete clID (playersIDs r)}) 0 rooms
+		) joinMsg
+	where
+		client = clients ! clID
+		joinMsg = if rID == 0 then
+				AnswerAllOthers ["LOBBY:JOINED", nick client]
+			else
+				AnswerThisRoom ["JOINED", nick client]
+
+
+processAction (clID, serverInfo, clients, rooms) (RoomRemoveThisClient) = do
+	when (rID /= 0) $ (processAction (clID, serverInfo, clients, rooms) $ AnswerOthersInRoom ["LEFT", nick client, "part"]) >> return ()
+	return (
+		clID,
+		serverInfo,
+		adjust (\cl -> cl{roomID = 0}) clID clients,
+		adjust (\r -> r{playersIDs = IntSet.delete clID (playersIDs r), playersIn = (playersIn r) - 1}) rID $
+			adjust (\r -> r{playersIDs = IntSet.insert clID (playersIDs r)}) 0 rooms
+		)
+	where
+		rID = roomID client
+		client = clients ! clID
+
+
+processAction (clID, serverInfo, clients, rooms) (AddRoom roomName roomPassword) = do
+	let newServerInfo = serverInfo {nextRoomID = newID}
+	let room = newRoom{
+			roomUID = newID,
+			name = roomName,
+			password = roomPassword,
+			roomProto = (clientProto client)
+			}
+
+	processAction (clID, serverInfo, clients, rooms) $ AnswerLobby ["ROOM", "ADD", roomName]
+
+	processAction (
+		clID,
+		newServerInfo,
+		adjust (\cl -> cl{isMaster = True}) clID clients,
+		insert newID room rooms
+		) $ RoomAddThisClient newID
+	where
+		newID = (nextRoomID serverInfo) - 1
+		client = clients ! clID
+
+
+processAction (clID, serverInfo, clients, rooms) (RemoveRoom) = do
+	processAction (clID, serverInfo, clients, rooms) $ AnswerLobby ["ROOM", "DEL", name clRoom]
+	processAction (clID, serverInfo, clients, rooms) $ AnswerOthersInRoom ["ROOMABANDONED", name clRoom]
+	return (clID,
+		serverInfo,
+		Data.IntMap.map (\cl -> if roomID cl == rID then cl{roomID = 0, isMaster = False} else cl) clients,
+		delete rID $ adjust (\r -> r{playersIDs = IntSet.union (playersIDs clRoom) (playersIDs r)}) 0 rooms
+		)
+	where
+		clRoom = rooms ! rID
+		rID = roomID client
+		client = clients ! clID
+
+processAction (clID, serverInfo, clients, rooms) (Dump) = do
+	writeChan (sendChan $ clients ! clID) ["DUMP", show serverInfo, showTree clients, showTree rooms]
+	return (clID, serverInfo, clients, rooms)
+
diff -r 95efe37482e3 -r 4e78ad846fb6 gameServer/ClientIO.hs
--- /dev/null	Thu Jan 01 00:00:00 1970 +0000
+++ b/gameServer/ClientIO.hs	Wed Feb 18 15:04:40 2009 +0000
@@ -0,0 +1,43 @@
+{-# LANGUAGE PatternSignatures #-}
+module ClientIO where
+
+import qualified Control.Exception
+import Control.Concurrent.Chan
+import Control.Monad
+import System.IO
+----------------
+import CoreTypes
+
+listenLoop :: Handle -> [String] -> Chan CoreMessage -> Int -> IO ()
+listenLoop handle buf chan clientID = do
+	str <- hGetLine handle
+	if str == "" then do
+		writeChan chan $ ClientMessage (clientID, buf)
+		listenLoop handle [] chan clientID
+		else
+		listenLoop handle (buf ++ [str]) chan clientID
+
+clientRecvLoop :: Handle -> Chan CoreMessage -> Int -> IO ()
+clientRecvLoop handle chan clientID =
+	listenLoop handle [] chan clientID
+		`catch` (\e -> (clientOff $ show e) >> return ())
+	where clientOff msg = writeChan chan $ ClientMessage (clientID, ["QUIT", msg]) -- if the client disconnects, we perform as if it sent QUIT message
+
+clientSendLoop :: Handle -> Chan CoreMessage -> Chan [String] -> Int -> IO()
+clientSendLoop handle coreChan chan clientID = do
+	answer <- readChan chan
+	doClose <- Control.Exception.handle
+		(\(e :: Control.Exception.Exception) -> if isQuit answer then return True else sendQuit e >> return False) $ do
+		forM_ answer (\str -> hPutStrLn handle str)
+		hPutStrLn handle ""
+		hFlush handle
+		return $ isQuit answer
+
+	if doClose then
+		Control.Exception.handle (\(_ :: Control.Exception.Exception) -> putStrLn "error on hClose") $ hClose handle
+		else
+		clientSendLoop handle coreChan chan clientID
+
+	where
+		sendQuit e = writeChan coreChan $ ClientMessage (clientID, ["QUIT", show e])
+		isQuit answer = head answer == "BYE"
diff -r 95efe37482e3 -r 4e78ad846fb6 gameServer/Codec/Binary/Base64.hs
--- /dev/null	Thu Jan 01 00:00:00 1970 +0000
+++ b/gameServer/Codec/Binary/Base64.hs	Wed Feb 18 15:04:40 2009 +0000
@@ -0,0 +1,113 @@
+-- |
+-- Module    : Codec.Binary.Base64
+-- Copyright : (c) 2007 Magnus Therning
+-- License   : BSD3
+--
+-- Implemented as specified in RFC 4648
+-- (<http://tools.ietf.org/html/rfc4648>).
+--
+-- Further documentation and information can be found at
+-- <http://www.haskell.org/haskellwiki/Library/Data_encoding>.
+module Codec.Binary.Base64
+    ( encode
+    , decode
+    , decode'
+    , chop
+    , unchop
+    ) where
+
+import Control.Monad
+import Data.Array
+import Data.Bits
+import Data.Maybe
+import Data.Word
+import qualified Data.Map as M
+
+-- {{{1 enc/dec map
+_encMap =
+    [ (0, 'A'), (1, 'B'), (2, 'C'), (3, 'D'), (4, 'E')
+    , (5, 'F') , (6, 'G'), (7, 'H'), (8, 'I'), (9, 'J')
+    , (10, 'K'), (11, 'L'), (12, 'M'), (13, 'N'), (14, 'O')
+    , (15, 'P'), (16, 'Q'), (17, 'R'), (18, 'S'), (19, 'T')
+    , (20, 'U'), (21, 'V'), (22, 'W'), (23, 'X'), (24, 'Y')
+    , (25, 'Z'), (26, 'a'), (27, 'b'), (28, 'c'), (29, 'd')
+    , (30, 'e'), (31, 'f'), (32, 'g'), (33, 'h'), (34, 'i')
+    , (35, 'j'), (36, 'k'), (37, 'l'), (38, 'm'), (39, 'n')
+    , (40, 'o'), (41, 'p'), (42, 'q'), (43, 'r'), (44, 's')
+    , (45, 't'), (46, 'u'), (47, 'v'), (48, 'w'), (49, 'x')
+    , (50, 'y'), (51, 'z'), (52, '0'), (53, '1'), (54, '2')
+    , (55, '3'), (56, '4'), (57, '5'), (58, '6'), (59, '7')
+    , (60, '8'), (61, '9'), (62, '+'), (63, '/') ]
+
+-- {{{1 encodeArray
+encodeArray :: Array Word8 Char
+encodeArray = array (0, 64) _encMap
+
+-- {{{1 decodeMap
+decodeMap :: M.Map Char Word8
+decodeMap  = M.fromList [(snd i, fst i) | i <- _encMap]
+
+-- {{{1 encode
+-- | Encode data.
+encode :: [Word8]
+    -> String
+encode = let
+        pad n = take n $ repeat 0
+        enc [] = ""
+        enc l@[o] = (++ "==") . take 2 .enc $ l ++ pad 2
+        enc l@[o1, o2] = (++ "=") . take 3 . enc $ l ++ pad 1
+        enc (o1:o2:o3:os) = let
+                i1 = o1 `shiftR` 2
+                i2 = (o1 `shiftL` 4 .|. o2 `shiftR` 4) .&. 0x3f
+                i3 = (o2 `shiftL` 2 .|. o3 `shiftR` 6) .&. 0x3f
+                i4 = o3 .&. 0x3f
+            in (foldr (\ i s -> (encodeArray ! i) : s) "" [i1, i2, i3, i4]) ++ enc os
+    in enc
+
+-- {{{1 decode
+-- | Decode data (lazy).
+decode' :: String
+    -> [Maybe Word8]
+decode' = let
+        pad n = take n $ repeat $ Just 0
+        dec [] = []
+        dec l@[Just eo1, Just eo2] = take 1 . dec $ l ++ pad 2
+        dec l@[Just eo1, Just eo2, Just eo3] = take 2 . dec $ l ++ pad 1
+        dec (Just eo1:Just eo2:Just eo3:Just eo4:eos) = let
+                o1 = eo1 `shiftL` 2 .|. eo2 `shiftR` 4
+                o2 = eo2 `shiftL` 4 .|. eo3 `shiftR` 2
+                o3 = eo3 `shiftL` 6 .|. eo4
+            in Just o1:Just o2:Just o3:(dec eos)
+        dec _ = [Nothing]
+    in
+        dec . map (flip M.lookup decodeMap) . takeWhile (/= '=')
+
+-- | Decode data (strict).
+decode :: String
+    -> Maybe [Word8]
+decode = sequence . decode'
+
+-- {{{1 chop
+-- | Chop up a string in parts.
+--
+--   The length given is rounded down to the nearest multiple of 4.
+--
+--   /Notes:/
+--
+--   * PEM requires lines that are 64 characters long.
+--
+--   * MIME requires lines that are at most 76 characters long.
+chop :: Int     -- ^ length of individual lines
+    -> String
+    -> [String]
+chop n "" = []
+chop n s = let
+        enc_len | n < 4 = 4
+                | otherwise = n `div` 4 * 4
+    in (take enc_len s) : chop n (drop enc_len s)
+
+-- {{{1 unchop
+-- | Concatenate the strings into one long string.
+unchop :: [String]
+    -> String
+unchop = foldr (++) ""
diff -r 95efe37482e3 -r 4e78ad846fb6 gameServer/Codec/Binary/UTF8/String.hs
--- /dev/null	Thu Jan 01 00:00:00 1970 +0000
+++ b/gameServer/Codec/Binary/UTF8/String.hs	Wed Feb 18 15:04:40 2009 +0000
@@ -0,0 +1,97 @@
+--
+-- |
+-- Module      :  Codec.Binary.UTF8.String
+-- Copyright   :  (c) Eric Mertens 2007
+-- License     :  BSD3-style (see LICENSE)
+-- 
+-- Maintainer:    emertens@galois.com
+-- Stability   :  experimental
+-- Portability :  portable
+--
+-- Support for encoding UTF8 Strings to and from @[Word8]@
+--
+
+module Codec.Binary.UTF8.String (
+      encode
+    , decode
+    , encodeString
+    , decodeString
+  ) where
+
+import Data.Word        (Word8)
+import Data.Bits        ((.|.),(.&.),shiftL,shiftR)
+import Data.Char        (chr,ord)
+
+default(Int)
+
+-- | Encode a string using 'encode' and store the result in a 'String'.
+encodeString :: String -> String
+encodeString xs = map (toEnum . fromEnum) (encode xs)
+
+-- | Decode a string using 'decode' using a 'String' as input.
+-- | This is not safe but it is necessary if UTF-8 encoded text
+-- | has been loaded into a 'String' prior to being decoded.
+decodeString :: String -> String
+decodeString xs = decode (map (toEnum . fromEnum) xs)
+
+replacement_character :: Char
+replacement_character = '\xfffd'
+
+-- | Encode a Haskell String to a list of Word8 values, in UTF8 format.
+encode :: String -> [Word8]
+encode = concatMap (map fromIntegral . go . ord)
+ where
+  go oc
+   | oc <= 0x7f       = [oc]
+
+   | oc <= 0x7ff      = [ 0xc0 + (oc `shiftR` 6)
+                        , 0x80 + oc .&. 0x3f
+                        ]
+
+   | oc <= 0xffff     = [ 0xe0 + (oc `shiftR` 12)
+                        , 0x80 + ((oc `shiftR` 6) .&. 0x3f)
+                        , 0x80 + oc .&. 0x3f
+                        ]
+   | otherwise        = [ 0xf0 + (oc `shiftR` 18)
+                        , 0x80 + ((oc `shiftR` 12) .&. 0x3f)
+                        , 0x80 + ((oc `shiftR` 6) .&. 0x3f)
+                        , 0x80 + oc .&. 0x3f
+                        ]
+
+--
+-- | Decode a UTF8 string packed into a list of Word8 values, directly to String
+--
+decode :: [Word8] -> String
+decode [    ] = ""
+decode (c:cs)
+  | c < 0x80  = chr (fromEnum c) : decode cs
+  | c < 0xc0  = replacement_character : decode cs
+  | c < 0xe0  = multi1
+  | c < 0xf0  = multi_byte 2 0xf  0x800
+  | c < 0xf8  = multi_byte 3 0x7  0x10000
+  | c < 0xfc  = multi_byte 4 0x3  0x200000
+  | c < 0xfe  = multi_byte 5 0x1  0x4000000
+  | otherwise = replacement_character : decode cs
+  where
+    multi1 = case cs of
+      c1 : ds | c1 .&. 0xc0 == 0x80 ->
+        let d = ((fromEnum c .&. 0x1f) `shiftL` 6) .|.  fromEnum (c1 .&. 0x3f)
+        in if d >= 0x000080 then toEnum d : decode ds
+                            else replacement_character : decode ds
+      _ -> replacement_character : decode cs
+
+    multi_byte :: Int -> Word8 -> Int -> [Char]
+    multi_byte i mask overlong = aux i cs (fromEnum (c .&. mask))
+      where
+        aux 0 rs acc
+          | overlong <= acc && acc <= 0x10ffff &&
+            (acc < 0xd800 || 0xdfff < acc)     &&
+            (acc < 0xfffe || 0xffff < acc)      = chr acc : decode rs
+          | otherwise = replacement_character : decode rs
+
+        aux n (r:rs) acc
+          | r .&. 0xc0 == 0x80 = aux (n-1) rs
+                               $ shiftL acc 6 .|. fromEnum (r .&. 0x3f)
+
+        aux _ rs     _ = replacement_character : decode rs
+
diff -r 95efe37482e3 -r 4e78ad846fb6 gameServer/CoreTypes.hs
--- /dev/null	Thu Jan 01 00:00:00 1970 +0000
+++ b/gameServer/CoreTypes.hs	Wed Feb 18 15:04:40 2009 +0000
@@ -0,0 +1,151 @@
+module CoreTypes where
+
+import System.IO
+import Control.Concurrent.Chan
+import Control.Concurrent.STM
+import Data.Word
+import qualified Data.Map as Map
+import qualified Data.IntMap as IntMap
+import qualified Data.IntSet as IntSet
+import Data.Sequence(Seq, empty)
+import Network
+
+data ClientInfo =
+ ClientInfo
+	{
+		clientUID :: Int,
+		sendChan :: Chan [String],
+		clientHandle :: Handle,
+		host :: String,
+		nick :: String,
+		clientProto :: Word16,
+		roomID :: Int,
+		isMaster :: Bool,
+		isReady :: Bool,
+		forceQuit :: Bool,
+		partRoom :: Bool
+	}
+
+instance Show ClientInfo where
+	show ci = show $ clientUID ci
+
+instance Eq ClientInfo where
+	a1 == a2 = clientHandle a1 == clientHandle a2
+
+data HedgehogInfo =
+	HedgehogInfo String String
+
+data TeamInfo =
+	TeamInfo
+	{
+		teamowner :: String,
+		teamname :: String,
+		teamcolor :: String,
+		teamgrave :: String,
+		teamfort :: String,
+		teamvoicepack :: String,
+		difficulty :: Int,
+		hhnum :: Int,
+		hedgehogs :: [HedgehogInfo]
+	}
+
+data RoomInfo =
+	RoomInfo
+	{
+		roomUID :: Int,
+		name :: String,
+		password :: String,
+		roomProto :: Word16,
+		teams :: [TeamInfo],
+		gameinprogress :: Bool,
+		playersIn :: !Int,
+		readyPlayers :: Int,
+		playersIDs :: IntSet.IntSet,
+		isRestrictedJoins :: Bool,
+		isRestrictedTeams :: Bool,
+		roundMsgs :: Seq String,
+		leftTeams :: [String],
+		teamsAtStart :: [TeamInfo],
+		params :: Map.Map String [String]
+	}
+
+instance Show RoomInfo where
+	show ri = (show $ roomUID ri)
+			++ ", players ids: " ++ (show $ IntSet.size $ playersIDs ri)
+			++ ", players: " ++ (show $ playersIn ri)
+
+instance Eq RoomInfo where
+	a1 == a2 = roomUID a1 == roomUID a2
+
+newRoom = (
+	RoomInfo
+		0
+		""
+		""
+		0
+		[]
+		False
+		0
+		0
+		IntSet.empty
+		False
+		False
+		Data.Sequence.empty
+		[]
+		[]
+		(Map.singleton "MAP" ["+rnd+"])
+	)
+
+data StatisticsInfo =
+	StatisticsInfo
+	{
+		playersNumber :: Int,
+		roomsNumber :: Int
+	}
+
+data DBQuery =
+	HasRegistered String
+	| CheckPassword String
+
+data ServerInfo =
+	ServerInfo
+	{
+		isDedicated :: Bool,
+		serverMessage :: String,
+		adminPassword :: String,
+		listenPort :: PortNumber,
+		loginsNumber :: Int,
+		nextRoomID :: Int,
+		stats :: TMVar StatisticsInfo
+		--dbQueries :: TChan DBQuery
+	}
+
+instance Show ServerInfo where
+	show si = "Logins: " ++ (show $ loginsNumber si)
+
+newServerInfo = (
+	ServerInfo
+		True
+		"<h2><p align=center><a href=\"http://www.hedgewars.org/\">http://www.hedgewars.org/</a></p></h2>"
+		""
+		46631
+		0
+		0
+	)
+
+data CoreMessage =
+	Accept ClientInfo
+	| ClientMessage (Int, [String])
+	-- | CoreMessage String
+	-- | TimerTick
+
+
+type Clients = IntMap.IntMap ClientInfo
+type Rooms = IntMap.IntMap RoomInfo
+
+--type ClientsTransform = [ClientInfo] -> [ClientInfo]
+--type RoomsTransform = [RoomInfo] -> [RoomInfo]
+--type HandlesSelector = ClientInfo -> [ClientInfo] -> [RoomInfo] -> [ClientInfo]
+--type Answer = ServerInfo -> (HandlesSelector, [String])
+
+type ClientsSelector = Clients -> Rooms -> [Int]
diff -r 95efe37482e3 -r 4e78ad846fb6 gameServer/HWProtoCore.hs
--- /dev/null	Thu Jan 01 00:00:00 1970 +0000
+++ b/gameServer/HWProtoCore.hs	Wed Feb 18 15:04:40 2009 +0000
@@ -0,0 +1,35 @@
+module HWProtoCore where
+
+import qualified Data.IntMap as IntMap
+--------------------------------------
+import CoreTypes
+import Actions
+import Utils
+import Answers
+import HWProtoNEState
+import HWProtoLobbyState
+import HWProtoInRoomState
+
+handleCmd:: CmdHandler
+
+handleCmd clID _ _ ["PING"] = [AnswerThisClient ["PONG"]]
+
+handleCmd clID clients _ ("QUIT" : xs) =
+	(if isMaster client then [RemoveRoom] else [])
+	++ [ByeClient msg]
+	where
+		client = clients IntMap.! clID
+		clientNick = nick client
+		msg = if not $ null xs then head xs else ""
+
+
+handleCmd clID clients rooms cmd =
+	if null (nick client) || clientProto client == 0 then
+		handleCmd_NotEntered clID clients rooms cmd
+	else if roomID client == 0 then
+		handleCmd_lobby clID clients rooms cmd
+	else
+		handleCmd_inRoom clID clients rooms cmd
+	where
+		client = clients IntMap.! clID
+
diff -r 95efe37482e3 -r 4e78ad846fb6 gameServer/HWProtoInRoomState.hs
--- /dev/null	Thu Jan 01 00:00:00 1970 +0000
+++ b/gameServer/HWProtoInRoomState.hs	Wed Feb 18 15:04:40 2009 +0000
@@ -0,0 +1,162 @@
+module HWProtoInRoomState where
+
+import qualified Data.IntMap as IntMap
+import qualified Data.Map as Map
+import Data.Sequence(Seq, (|>), (><), fromList, empty)
+import Data.List
+import Maybe
+--------------------------------------
+import CoreTypes
+import Actions
+import Utils
+
+
+handleCmd_inRoom :: CmdHandler
+
+handleCmd_inRoom clID clients _ ["CHAT_STRING", msg] =
+	[AnswerOthersInRoom ["CHAT_STRING", clientNick, msg]]
+	where
+		clientNick = nick $ clients IntMap.! clID
+
+handleCmd_inRoom clID clients _ ["PART"] =
+	if isMaster client then
+		[RemoveRoom]
+	else
+		[RoomRemoveThisClient]
+	where
+		client = clients IntMap.! clID
+
+handleCmd_inRoom clID clients rooms ("CFG" : paramName : paramStrs) =
+	if isMaster client then
+		[ModifyRoom (\r -> r{params = Map.insert paramName paramStrs (params r)})
+		, AnswerOthersInRoom ("CFG" : paramName : paramStrs)]
+	else
+		[ProtocolError "Not room master"]
+	where
+		client = clients IntMap.! clID
+
+
+handleCmd_inRoom clID clients rooms ("ADD_TEAM" : name : color : grave : fort : voicepack : difStr : hhsInfo)
+	| length hhsInfo == 16 =
+	if length (teams room) == 6 then
+		[Warning "too many teams"]
+	else if canAddNumber <= 0 then
+		[Warning "too many hedgehogs"]
+	else if isJust findTeam then
+		[Warning "already have a team with same name"]
+	else if gameinprogress room then
+		[Warning "round in progress"]
+	else if isRestrictedTeams room then
+		[Warning "restricted"]
+	else
+		[ModifyRoom (\r -> r{teams = teams r ++ [newTeam]}),
+		AnswerThisClient ["TEAM_ACCEPTED", name],
+		AnswerOthersInRoom $ teamToNet newTeam,
+		AnswerOthersInRoom ["TEAM_COLOR", name, color]
+		]
+	where
+		client = clients IntMap.! clID
+		room = rooms IntMap.! (roomID client)
+		canAddNumber = 48 - (sum . map hhnum $ teams room)
+		findTeam = find (\t -> name == teamname t) $ teams room
+		newTeam = (TeamInfo (nick client) name color grave fort voicepack difficulty newTeamHHNum (hhsList hhsInfo))
+		difficulty = fromMaybe 0 (maybeRead difStr :: Maybe Int)
+		hhsList [] = []
+		hhsList (n:h:hhs) = HedgehogInfo n h : hhsList hhs
+		newTeamHHNum = min 4 canAddNumber
+
+
+handleCmd_inRoom clID clients rooms ["REMOVE_TEAM", teamName] =
+	if noSuchTeam then
+		[Warning "REMOVE_TEAM: no such team"]
+	else
+		if not $ nick client == teamowner team then
+			[ProtocolError "Not team owner!"]
+		else
+			if not $ gameinprogress room then
+				[ModifyRoom (\r -> r{teams = filter (\t -> teamName /= teamname t) $ teams r}),
+				AnswerOthersInRoom ["REMOVE_TEAM", teamName]]
+			else
+				[]
+{-			else
+				(noChangeClients,
+				modifyRoom clRoom{
+					teams = filter (\t -> teamName /= teamname t) $ teams clRoom,
+					leftTeams = teamName : leftTeams clRoom,
+					roundMsgs = roundMsgs clRoom |> rmTeamMsg
+					},
+				answerOthersRoom ["GAMEMSG", rmTeamMsg]) -}
+	where
+		client = clients IntMap.! clID
+		room = rooms IntMap.! (roomID client)
+		noSuchTeam = isNothing findTeam
+		team = fromJust findTeam
+		findTeam = find (\t -> teamName == teamname t) $ teams room
+		rmTeamMsg = toEngineMsg $ 'F' : teamName
+
+
+handleCmd_inRoom clID clients rooms ["HH_NUM", teamName, numberStr] =
+	if not $ isMaster client then
+		[ProtocolError "Not room master"]
+	else
+		if hhNumber < 1 || hhNumber > 8 || noSuchTeam || hhNumber > (canAddNumber + (hhnum team)) then
+			[]
+		else
+			[ModifyRoom $ modifyTeam team{hhnum = hhNumber},
+			AnswerOthersInRoom ["HH_NUM", teamName, show hhNumber]]
+	where
+		client = clients IntMap.! clID
+		room = rooms IntMap.! (roomID client)
+		hhNumber = fromMaybe 0 (maybeRead numberStr :: Maybe Int)
+		noSuchTeam = isNothing findTeam
+		team = fromJust findTeam
+		findTeam = find (\t -> teamName == teamname t) $ teams room
+		canAddNumber = 48 - (sum . map hhnum $ teams room)
+
+
+handleCmd_inRoom clID clients rooms ["TEAM_COLOR", teamName, newColor] =
+	if not $ isMaster client then
+		[ProtocolError "Not room master"]
+	else
+		if noSuchTeam then
+			[]
+		else
+			[ModifyRoom $ modifyTeam team{teamcolor = newColor},
+			AnswerOthersInRoom ["TEAM_COLOR", teamName, newColor]]
+	where
+		noSuchTeam = isNothing findTeam
+		team = fromJust findTeam
+		findTeam = find (\t -> teamName == teamname t) $ teams room
+		client = clients IntMap.! clID
+		room = rooms IntMap.! (roomID client)
+
+
+handleCmd_inRoom clID clients rooms ["TOGGLE_READY"] =
+	[ModifyClient (\c -> c{isReady = not $ isReady client}),
+	ModifyRoom (\r -> r{readyPlayers = readyPlayers r + (if isReady client then -1 else 1)}),
+	AnswerThisRoom $ [if isReady client then "NOT_READY" else "READY", nick client]]
+	where
+		client = clients IntMap.! clID
+
+
+handleCmd_inRoom clID clients rooms ["START_GAME"] =
+	if isMaster client && (playersIn room == readyPlayers room) && (not $ gameinprogress room) then
+		if enoughClans then
+			[ModifyRoom (\r -> r{gameinprogress = True, roundMsgs = empty, leftTeams = [], teamsAtStart = teams r}),
+			AnswerThisRoom ["RUN_GAME"]]
+		else
+			[Warning "Less than two clans!"]
+	else
+		[]
+	where
+		client = clients IntMap.! clID
+		room = rooms IntMap.! (roomID client)
+		enoughClans = not $ null $ drop 1 $ group $ map teamcolor $ teams room
+
+
+handleCmd_inRoom client _ rooms ["GAMEMSG", msg] =
+	[ModifyRoom (\r -> r{roundMsgs = roundMsgs r |> msg}),
+	AnswerOthersInRoom ["GAMEMSG", msg]]
+
+
+handleCmd_inRoom clID _ _ _ = [ProtocolError "Incorrect command (state: in room)"]
diff -r 95efe37482e3 -r 4e78ad846fb6 gameServer/HWProtoLobbyState.hs
--- /dev/null	Thu Jan 01 00:00:00 1970 +0000
+++ b/gameServer/HWProtoLobbyState.hs	Wed Feb 18 15:04:40 2009 +0000
@@ -0,0 +1,105 @@
+module HWProtoLobbyState where
+
+import qualified Data.Map as Map
+import qualified Data.IntMap as IntMap
+import qualified Data.IntSet as IntSet
+import Maybe
+import Data.List
+--------------------------------------
+import CoreTypes
+import Actions
+import Answers
+import Utils
+
+answerAllTeams teams = concatMap toAnswer teams
+	where
+		toAnswer team =
+			[AnswerThisClient $ teamToNet team,
+			AnswerThisClient ["TEAM_COLOR", teamname team, teamcolor team],
+			AnswerThisClient ["HH_NUM", teamname team, show $ hhnum team]]
+
+handleCmd_lobby :: CmdHandler
+
+handleCmd_lobby clID clients rooms ["LIST"] =
+	[AnswerThisClient ("ROOMS" : roomsInfoList)]
+	where
+		roomsInfoList = concatMap roomInfo $ sameProtoRooms
+		sameProtoRooms = filter (\r -> (roomProto r == protocol) && (not $ isRestrictedJoins r)) roomsList
+		roomsList = IntMap.elems rooms
+		protocol = clientProto client
+		client = clients IntMap.! clID
+		roomInfo room = [
+				name room,
+				(show $ playersIn room) ++ "(" ++ (show $ length $ teams room) ++ ")",
+				show $ gameinprogress room
+				]
+
+handleCmd_lobby clID clients _ ["CHAT_STRING", msg] =
+	[AnswerOthersInRoom ["CHAT_STRING", clientNick, msg]]
+	where
+		clientNick = nick $ clients IntMap.! clID
+
+handleCmd_lobby clID clients rooms ["CREATE", newRoom, roomPassword] =
+	if haveSameRoom then
+		[Warning "Room exists"]
+	else
+		[RoomRemoveThisClient, -- leave lobby
+		AddRoom newRoom roomPassword,
+		AnswerThisClient ["NOT_READY", clientNick]
+		]
+	where
+		clientNick = nick $ clients IntMap.! clID
+		haveSameRoom = isJust $ find (\room -> newRoom == name room) $ IntMap.elems rooms
+
+handleCmd_lobby clID clients rooms ["CREATE", newRoom] =
+	handleCmd_lobby clID clients rooms ["CREATE", newRoom, ""]
+
+handleCmd_lobby clID clients rooms ["JOIN", roomName, roomPassword] =
+	if noSuchRoom then
+		[Warning "No such room"]
+	else if isRestrictedJoins jRoom then
+		[Warning "Joining restricted"]
+	else if roomPassword /= password jRoom then
+		[Warning "Wrong password"]
+	else
+		[RoomRemoveThisClient, -- leave lobby
+		RoomAddThisClient rID] -- join room
+		++ answerNicks
+		++ answerReady
+		++ [AnswerThisRoom ["NOT_READY", nick client]]
+		++ answerFullConfig jRoom
+		++ answerTeams
+--		++ watchRound)
+	where
+		noSuchRoom = isNothing mbRoom
+		mbRoom = find (\r -> roomName == name r && roomProto r == clientProto client) $ IntMap.elems rooms 
+		jRoom = fromJust mbRoom
+		rID = roomUID jRoom
+		client = clients IntMap.! clID
+		roomClientsIDs = IntSet.elems $ playersIDs jRoom
+		answerNicks = if playersIn jRoom /= 0 then
+					[AnswerThisClient $ ["JOINED"] ++ (map (\clID -> nick $ clients IntMap.! clID) $ roomClientsIDs)]
+				else
+					[]
+		answerReady =
+			map (\c -> AnswerThisClient [if isReady c then "READY" else "NOT_READY", nick c]) $
+			map (\clID -> clients IntMap.! clID) roomClientsIDs
+
+		toAnswer (paramName, paramStrs) = AnswerThisClient $ "CFG" : paramName : paramStrs
+		answerFullConfig room = map toAnswer (Map.toList $ params room)
+{-
+		watchRound = if (roomProto clRoom < 20) || (not $ gameinprogress clRoom) then
+					[]
+				else
+					(answerClientOnly  ["RUN_GAME"]) ++
+					answerClientOnly ("GAMEMSG" : toEngineMsg "e$spectate 1" : (toList $ roundMsgs clRoom)) -}
+		answerTeams = if gameinprogress jRoom then
+				answerAllTeams (teamsAtStart jRoom)
+			else
+				answerAllTeams (teams jRoom)
+
+
+handleCmd_lobby client clients rooms ["JOIN", roomName] =
+	handleCmd_lobby client clients rooms ["JOIN", roomName, ""]
+
+handleCmd_lobby clID _ _ _ = [ProtocolError "Incorrect command (state: in lobby)"]
diff -r 95efe37482e3 -r 4e78ad846fb6 gameServer/HWProtoNEState.hs
--- /dev/null	Thu Jan 01 00:00:00 1970 +0000
+++ b/gameServer/HWProtoNEState.hs	Wed Feb 18 15:04:40 2009 +0000
@@ -0,0 +1,63 @@
+module HWProtoNEState where
+
+import qualified Data.IntMap as IntMap
+import Maybe
+import Data.List
+import Data.Word
+--------------------------------------
+import CoreTypes
+import Actions
+import Utils
+
+handleCmd_NotEntered :: CmdHandler
+
+onLoginFinished :: Int -> String -> Word16 -> Clients -> [Action]
+onLoginFinished clID clientNick clProto clients =
+	if (null $ clientNick) || (clProto == 0) then
+		[]
+	else
+		(RoomAddThisClient 0)
+		: answerLobbyNicks
+		-- ++ (answerServerMessage client clients)
+	where
+		lobbyNicks = filter (\n -> (not (null n))) $ map nick $ IntMap.elems clients
+		answerLobbyNicks = if not $ null lobbyNicks then
+					[AnswerThisClient (["LOBBY:JOINED"] ++ lobbyNicks)]
+				else
+					[]
+
+
+handleCmd_NotEntered clID clients _ ["NICK", newNick] =
+	if not . null $ nick client then
+		[ProtocolError "Nick already chosen"]
+	else if haveSameNick then
+		[AnswerThisClient ["WARNING", "Nick collision"]]
+		++ [ByeClient ""]
+	else
+		[ModifyClient (\c -> c{nick = newNick}),
+		AnswerThisClient ["NICK", newNick]]
+		++ (onLoginFinished clID newNick (clientProto client) clients)
+	where
+		client = clients IntMap.! clID
+		haveSameNick = isJust $ find (\cl -> newNick == nick cl) $ IntMap.elems clients
+
+
+handleCmd_NotEntered clID clients _ ["PROTO", protoNum] =
+	if clientProto client > 0 then
+		[ProtocolError "Protocol already known"]
+	else if parsedProto == 0 then
+		[ProtocolError "Bad number"]
+	else
+		[ModifyClient (\c -> c{clientProto = parsedProto}),
+		AnswerThisClient ["PROTO", show parsedProto]]
+		++ (onLoginFinished clID (nick client) parsedProto clients)
+	where
+		client = clients IntMap.! clID
+		parsedProto = fromMaybe 0 (maybeRead protoNum :: Maybe Word16)
+
+
+handleCmd_NotEntered _ _ _ ["DUMP"] =
+	[Dump]
+
+
+handleCmd_NotEntered clID _ _ _ = [ProtocolError "Incorrect command (state: not entered)"]
diff -r 95efe37482e3 -r 4e78ad846fb6 gameServer/NetRoutines.hs
--- /dev/null	Thu Jan 01 00:00:00 1970 +0000
+++ b/gameServer/NetRoutines.hs	Wed Feb 18 15:04:40 2009 +0000
@@ -0,0 +1,60 @@
+{-# 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
+					""
+					0
+					0
+					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
diff -r 95efe37482e3 -r 4e78ad846fb6 gameServer/OfficialServer/DBInteraction.hs
--- /dev/null	Thu Jan 01 00:00:00 1970 +0000
+++ b/gameServer/OfficialServer/DBInteraction.hs	Wed Feb 18 15:04:40 2009 +0000
@@ -0,0 +1,37 @@
+module OfficialServer.DBInteraction
+(
+	startDBConnection,
+	DBQuery(HasRegistered, CheckPassword)
+) where
+
+import Database.HDBC
+import Database.HDBC.MySQL
+
+import System.IO
+import Control.Concurrent
+import Control.Concurrent.STM
+import Control.Exception
+
+data DBQuery =
+	HasRegistered String
+	| CheckPassword String
+
+dbInteractionLoop queries dbConn = do
+	q <- atomically $ readTChan queries
+	case q of
+		HasRegistered queryStr -> putStrLn queryStr
+		CheckPassword queryStr -> putStrLn queryStr
+
+	dbInteractionLoop queries dbConn
+
+dbConnectionLoop queries = do
+	Control.Exception.handle (\e -> print e) $ handleSqlError $
+		bracket
+			(connectMySQL defaultMySQLConnectInfo { mysqlHost = "192.168.50.5", mysqlDatabase = "glpi" })
+			(disconnect)
+			(dbInteractionLoop queries)
+
+	threadDelay (15 * 10^6)
+	dbConnectionLoop queries
+
+startDBConnection queries = forkIO $ dbConnectionLoop queries
diff -r 95efe37482e3 -r 4e78ad846fb6 gameServer/Opts.hs
--- /dev/null	Thu Jan 01 00:00:00 1970 +0000
+++ b/gameServer/Opts.hs	Wed Feb 18 15:04:40 2009 +0000
@@ -0,0 +1,37 @@
+module Opts
+(
+	getOpts,
+) where
+
+import System
+import System.Console.GetOpt
+import Network
+import Data.Maybe ( fromMaybe )
+import CoreTypes
+import Utils
+
+options :: [OptDescr (ServerInfo -> ServerInfo)]
+options = [
+	Option ['p'] ["port"] (ReqArg readListenPort "PORT") "listen on PORT",
+	Option ['d'] ["dedicated"] (ReqArg readDedicated "BOOL") "start as dedicated (True or False)",
+	Option []    ["password"] (ReqArg readPassword "STRING") "admin password"
+	]
+
+readListenPort, readDedicated, readPassword :: String -> ServerInfo -> ServerInfo
+readListenPort str opts = opts{listenPort = readPort}
+	where
+		readPort = fromInteger $ fromMaybe 46631 (maybeRead str :: Maybe Integer)
+
+readDedicated str opts = opts{isDedicated = readDedicated}
+	where
+		readDedicated = fromMaybe True (maybeRead str :: Maybe Bool)
+
+readPassword str opts = opts{adminPassword = str}
+
+getOpts :: ServerInfo -> IO ServerInfo
+getOpts opts = do
+	args <- getArgs
+	case getOpt Permute options args of
+		(o, [], []) -> return $ foldr ($) opts o
+		(_,_,errs) -> ioError (userError (concat errs ++ usageInfo header options))
+	where header = "Usage: newhwserv [OPTION...]"
diff -r 95efe37482e3 -r 4e78ad846fb6 gameServer/ServerCore.hs
--- /dev/null	Thu Jan 01 00:00:00 1970 +0000
+++ b/gameServer/ServerCore.hs	Wed Feb 18 15:04:40 2009 +0000
@@ -0,0 +1,72 @@
+module ServerCore where
+
+import Network
+import Control.Concurrent
+import Control.Concurrent.STM
+import Control.Concurrent.Chan
+import Control.Monad
+import qualified Data.IntMap as IntMap
+import System.Log.Logger
+--------------------------------------
+import CoreTypes
+import NetRoutines
+import Utils
+import HWProtoCore
+import Actions
+
+reactCmd :: ServerInfo -> Int -> [String] -> Clients -> Rooms -> IO (ServerInfo, Clients, Rooms)
+reactCmd serverInfo clID cmd clients rooms = do
+	(_ , serverInfo, clients, rooms) <-
+		foldM processAction (clID, serverInfo, clients, rooms) $ handleCmd clID clients rooms cmd
+	return (serverInfo, clients, rooms)
+
+mainLoop :: Chan CoreMessage -> ServerInfo -> Clients -> Rooms -> IO ()
+mainLoop coreChan serverInfo clients rooms = do
+	r <- readChan coreChan
+	
+	(newServerInfo, mClients, mRooms) <-
+		case r of
+			Accept ci -> do
+				let updatedClients = IntMap.insert (clientUID ci) ci clients
+				--infoM "Clients" ("New client: id " ++ (show $ clientUID ci))
+				processAction
+					(clientUID ci, serverInfo, updatedClients, rooms)
+					(AnswerThisClient ["CONNECTED", "Hedgewars server http://www.hedgewars.org/"])
+				return (serverInfo, updatedClients, rooms)
+
+			ClientMessage (clID, cmd) -> do
+				debugM "Clients" $ (show clID) ++ ": " ++ (show cmd)
+				if clID `IntMap.member` clients then
+					reactCmd serverInfo clID cmd clients rooms
+					else
+					do
+					debugM "Clients" "Message from dead client"
+					return (serverInfo, clients, rooms)
+
+	{-			let hadRooms = (not $ null rooms) && (null mrooms)
+					in unless ((not $ isDedicated serverInfo) && ((null clientsIn) || hadRooms)) $
+						mainLoop serverInfo acceptChan messagesChan clientsIn mrooms -}
+
+	mainLoop coreChan newServerInfo mClients mRooms
+
+startServer :: ServerInfo -> Chan CoreMessage -> Socket -> IO ()
+startServer serverInfo coreChan serverSocket = do
+	putStrLn $ "Listening on port " ++ show (listenPort serverInfo)
+
+	forkIO $
+		acceptLoop
+			serverSocket
+			coreChan
+			0
+
+	return ()
+	
+{-	forkIO $ messagesLoop messagesChan
+	forkIO $ timerLoop messagesChan-}
+
+--	startDBConnection $ dbQueries serverInfo
+
+	mainLoop coreChan serverInfo IntMap.empty (IntMap.singleton 0 newRoom)
+
+
+
diff -r 95efe37482e3 -r 4e78ad846fb6 gameServer/Utils.hs
--- /dev/null	Thu Jan 01 00:00:00 1970 +0000
+++ b/gameServer/Utils.hs	Wed Feb 18 15:04:40 2009 +0000
@@ -0,0 +1,58 @@
+module Utils where
+
+import Control.Concurrent
+import Control.Concurrent.STM
+import Data.Char
+import Data.Word
+import qualified Data.Map as Map
+import qualified Data.IntMap as IntMap
+-------------------------------------------------
+import qualified Codec.Binary.Base64 as Base64
+import qualified Codec.Binary.UTF8.String as UTF8
+import CoreTypes
+
+toEngineMsg :: String -> String
+toEngineMsg msg = Base64.encode (fromIntegral (length msg) : (UTF8.encode msg))
+
+--tselect :: [ClientInfo] -> STM ([String], ClientInfo)
+--tselect = foldl orElse retry . map (\ci -> (flip (,) ci) `fmap` readTChan (chan ci))
+
+maybeRead :: Read a => String -> Maybe a
+maybeRead s = case reads s of
+	[(x, rest)] | all isSpace rest -> Just x
+	_         -> Nothing
+
+teamToNet team = [
+		"ADD_TEAM",
+		teamname team,
+		teamgrave team,
+		teamfort team,
+		teamvoicepack team,
+		teamowner team,
+		show $ difficulty team
+		]
+		++ hhsInfo
+	where
+		hhsInfo = concatMap (\(HedgehogInfo name hat) -> [name, hat]) $ hedgehogs team
+
+modifyTeam :: TeamInfo -> RoomInfo -> RoomInfo
+modifyTeam team room = room{teams = replaceTeam team $ teams room}
+	where
+	replaceTeam _ [] = error "modifyTeam: no such team"
+	replaceTeam team (t:teams) =
+		if teamname team == teamname t then
+			team : teams
+		else
+			t : replaceTeam team teams
+
+protoNumber2ver :: Word16 -> String
+protoNumber2ver 17 = "0.9.7-dev"
+protoNumber2ver 19 = "0.9.7"
+protoNumber2ver 20 = "0.9.8-dev"
+protoNumber2ver 21 = "0.9.8"
+protoNumber2ver 22 = "0.9.9-dev"
+protoNumber2ver 23 = "0.9.9"
+protoNumber2ver 24 = "0.9.10-dev"
+protoNumber2ver 25 = "0.9.10"
+protoNumber2ver _ = "Unknown"
+
diff -r 95efe37482e3 -r 4e78ad846fb6 gameServer/hedgewars-server.hs
--- /dev/null	Thu Jan 01 00:00:00 1970 +0000
+++ b/gameServer/hedgewars-server.hs	Wed Feb 18 15:04:40 2009 +0000
@@ -0,0 +1,58 @@
+{-# LANGUAGE CPP, ScopedTypeVariables, PatternSignatures #-}
+
+module Main where
+
+import Network.Socket
+import qualified Network
+import Control.Concurrent.STM
+import Control.Concurrent.Chan
+import Control.Exception
+import System.Log.Logger
+-----------------------------------
+import Opts
+import CoreTypes
+import OfficialServer.DBInteraction
+import ServerCore
+
+
+#if !defined(mingw32_HOST_OS)
+import System.Posix
+#endif
+
+
+{-data Messages =
+	Accept ClientInfo
+	| ClientMessage ([String], ClientInfo)
+	| CoreMessage [String]
+	| TimerTick
+
+messagesLoop :: TChan String -> IO()
+messagesLoop messagesChan = forever $ do
+	threadDelay (25 * 10^6) -- 25 seconds
+	atomically $ writeTChan messagesChan "PING"
+
+timerLoop :: TChan String -> IO()
+timerLoop messagesChan = forever $ do
+	threadDelay (60 * 10^6) -- 60 seconds
+	atomically $ writeTChan messagesChan "MINUTELY"-}
+
+setupLoggers =
+	updateGlobalLogger "Clients"
+		(setLevel DEBUG)
+
+main = withSocketsDo $ do
+#if !defined(mingw32_HOST_OS)
+	installHandler sigPIPE Ignore Nothing;
+#endif
+
+	setupLoggers
+
+	stats <- atomically $ newTMVar (StatisticsInfo 0 0)
+	--dbQueriesChan <- atomically newTChan
+	coreChan <- newChan
+	serverInfo <- getOpts $ newServerInfo stats -- dbQueriesChan
+	
+	bracket
+		(Network.listenOn $ Network.PortNumber $ listenPort serverInfo)
+		(sClose)
+		(startServer serverInfo coreChan)
diff -r 95efe37482e3 -r 4e78ad846fb6 gameServer/stresstest.hs
--- /dev/null	Thu Jan 01 00:00:00 1970 +0000
+++ b/gameServer/stresstest.hs	Wed Feb 18 15:04:40 2009 +0000
@@ -0,0 +1,51 @@
+{-# LANGUAGE CPP #-}
+
+module Main where
+
+import IO
+import System.IO
+import Control.Concurrent
+import Network
+import Control.Exception
+import Control.Monad
+import System.Random
+
+#if !defined(mingw32_HOST_OS)
+import System.Posix
+#endif
+
+session1 nick room = ["NICK", nick, "", "PROTO", "24", "", "CHAT_STRING", "lobby 1", "", "CREATE", room, "", "CHAT_STRING", "room 1", "", "QUIT", "bye-bye", ""]
+session2 nick room = ["NICK", nick, "", "PROTO", "24", "", "LIST", "", "JOIN", room, "", "CHAT_STRING", "room 2", "", "PART", "", "CHAT_STRING", "lobby after part", "", "QUIT", "bye-bye", ""]
+session3 nick room = ["NICK", nick, "", "PROTO", "24", "", "LIST", "", "JOIN", room, "", "CHAT_STRING", "room 2", "", "QUIT", "bye-bye", ""]
+
+emulateSession sock s = do
+	mapM_ (\x -> hPutStrLn sock x >> hFlush sock >> randomRIO (50000::Int, 90000) >>= threadDelay) s
+	hFlush sock
+	threadDelay 225000
+
+testing = Control.Exception.handle (\e -> putStrLn $ show e) $ do
+	putStrLn "Start"
+	sock <- connectTo "127.0.0.1" (PortNumber 46631)
+
+	num1 <- randomRIO (70000::Int, 70100)
+	num2 <- randomRIO (0::Int, 2)
+	num3 <- randomRIO (0::Int, 5)
+	let nick1 = show $ num1
+	let room1 = show $ num2
+	case num2 of 
+		0 -> emulateSession sock $ session1 nick1 room1
+		1 -> emulateSession sock $ session2 nick1 room1
+		2 -> emulateSession sock $ session3 nick1 room1
+	hClose sock
+	putStrLn "Finish"
+
+forks = forever $ do
+	delay <- randomRIO (10000::Int, 19000)
+	threadDelay delay
+	forkIO testing
+
+main = withSocketsDo $ do
+#if !defined(mingw32_HOST_OS)
+	installHandler sigPIPE Ignore Nothing;
+#endif
+	forks
diff -r 95efe37482e3 -r 4e78ad846fb6 gameServer/stresstest2.hs
--- /dev/null	Thu Jan 01 00:00:00 1970 +0000
+++ b/gameServer/stresstest2.hs	Wed Feb 18 15:04:40 2009 +0000
@@ -0,0 +1,35 @@
+{-# LANGUAGE CPP #-}
+
+module Main where
+
+import IO
+import System.IO
+import Control.Concurrent
+import Network
+import Control.Exception
+import Control.Monad
+import System.Random
+
+#if !defined(mingw32_HOST_OS)
+import System.Posix
+#endif
+
+testing = Control.Exception.handle (\e -> putStrLn $ show e) $ do
+	delay <- randomRIO (100::Int, 300)
+	threadDelay delay
+	sock <- connectTo "127.0.0.1" (PortNumber 46631)
+	hClose sock
+
+forks i = do
+	delay <- randomRIO (50::Int, 190)
+	if i `mod` 10 == 0 then putStr (show i) else putStr "."
+	hFlush stdout
+	threadDelay delay
+	forkIO testing
+	forks (i + 1)
+
+main = withSocketsDo $ do
+#if !defined(mingw32_HOST_OS)
+	installHandler sigPIPE Ignore Nothing;
+#endif
+	forks 1