gameServer/Utils.hs
author unc0rr
Fri, 01 May 2009 09:01:44 +0000
changeset 2021 a591afb43768
parent 1964 dc9ea05c9d2f
child 2113 89d0fa6734af
permissions -rw-r--r--
Some changes in try to fix issue when you enter room with painted map, but frontend shows generated one (most probably bug is triggered by template filters) Untested.
Ignore whitespace changes - Everywhere: Within whitespace: At end of lines:
1804
4e78ad846fb6 New game server:
unc0rr
parents:
diff changeset
     1
module Utils where
4e78ad846fb6 New game server:
unc0rr
parents:
diff changeset
     2
4e78ad846fb6 New game server:
unc0rr
parents:
diff changeset
     3
import Control.Concurrent
4e78ad846fb6 New game server:
unc0rr
parents:
diff changeset
     4
import Control.Concurrent.STM
4e78ad846fb6 New game server:
unc0rr
parents:
diff changeset
     5
import Data.Char
4e78ad846fb6 New game server:
unc0rr
parents:
diff changeset
     6
import Data.Word
4e78ad846fb6 New game server:
unc0rr
parents:
diff changeset
     7
import qualified Data.Map as Map
4e78ad846fb6 New game server:
unc0rr
parents:
diff changeset
     8
import qualified Data.IntMap as IntMap
1917
c94045b70142 - Better ip2string implementation
unc0rr
parents: 1804
diff changeset
     9
import Numeric
c94045b70142 - Better ip2string implementation
unc0rr
parents: 1804
diff changeset
    10
import Network.Socket
1964
dc9ea05c9d2f - Another way of defining official server
unc0rr
parents: 1953
diff changeset
    11
import System.IO
1917
c94045b70142 - Better ip2string implementation
unc0rr
parents: 1804
diff changeset
    12
import qualified Data.List as List
1804
4e78ad846fb6 New game server:
unc0rr
parents:
diff changeset
    13
-------------------------------------------------
4e78ad846fb6 New game server:
unc0rr
parents:
diff changeset
    14
import qualified Codec.Binary.Base64 as Base64
4e78ad846fb6 New game server:
unc0rr
parents:
diff changeset
    15
import qualified Codec.Binary.UTF8.String as UTF8
4e78ad846fb6 New game server:
unc0rr
parents:
diff changeset
    16
import CoreTypes
4e78ad846fb6 New game server:
unc0rr
parents:
diff changeset
    17
1917
c94045b70142 - Better ip2string implementation
unc0rr
parents: 1804
diff changeset
    18
c94045b70142 - Better ip2string implementation
unc0rr
parents: 1804
diff changeset
    19
sockAddr2String :: SockAddr -> IO String
c94045b70142 - Better ip2string implementation
unc0rr
parents: 1804
diff changeset
    20
sockAddr2String (SockAddrInet _ hostAddr) = inet_ntoa hostAddr
c94045b70142 - Better ip2string implementation
unc0rr
parents: 1804
diff changeset
    21
sockAddr2String (SockAddrInet6 _ _ (a, b, c, d) _) =
c94045b70142 - Better ip2string implementation
unc0rr
parents: 1804
diff changeset
    22
	return $ (foldr1 (.)
c94045b70142 - Better ip2string implementation
unc0rr
parents: 1804
diff changeset
    23
		$ List.intersperse (\a -> ':':a)
c94045b70142 - Better ip2string implementation
unc0rr
parents: 1804
diff changeset
    24
		$ concatMap (\n -> (\(a, b) -> [showHex a, showHex b]) $ divMod n 65536) [a, b, c, d]) []
c94045b70142 - Better ip2string implementation
unc0rr
parents: 1804
diff changeset
    25
1804
4e78ad846fb6 New game server:
unc0rr
parents:
diff changeset
    26
toEngineMsg :: String -> String
4e78ad846fb6 New game server:
unc0rr
parents:
diff changeset
    27
toEngineMsg msg = Base64.encode (fromIntegral (length msg) : (UTF8.encode msg))
4e78ad846fb6 New game server:
unc0rr
parents:
diff changeset
    28
4e78ad846fb6 New game server:
unc0rr
parents:
diff changeset
    29
--tselect :: [ClientInfo] -> STM ([String], ClientInfo)
4e78ad846fb6 New game server:
unc0rr
parents:
diff changeset
    30
--tselect = foldl orElse retry . map (\ci -> (flip (,) ci) `fmap` readTChan (chan ci))
4e78ad846fb6 New game server:
unc0rr
parents:
diff changeset
    31
4e78ad846fb6 New game server:
unc0rr
parents:
diff changeset
    32
maybeRead :: Read a => String -> Maybe a
4e78ad846fb6 New game server:
unc0rr
parents:
diff changeset
    33
maybeRead s = case reads s of
4e78ad846fb6 New game server:
unc0rr
parents:
diff changeset
    34
	[(x, rest)] | all isSpace rest -> Just x
4e78ad846fb6 New game server:
unc0rr
parents:
diff changeset
    35
	_         -> Nothing
4e78ad846fb6 New game server:
unc0rr
parents:
diff changeset
    36
4e78ad846fb6 New game server:
unc0rr
parents:
diff changeset
    37
teamToNet team = [
4e78ad846fb6 New game server:
unc0rr
parents:
diff changeset
    38
		"ADD_TEAM",
4e78ad846fb6 New game server:
unc0rr
parents:
diff changeset
    39
		teamname team,
4e78ad846fb6 New game server:
unc0rr
parents:
diff changeset
    40
		teamgrave team,
4e78ad846fb6 New game server:
unc0rr
parents:
diff changeset
    41
		teamfort team,
4e78ad846fb6 New game server:
unc0rr
parents:
diff changeset
    42
		teamvoicepack team,
4e78ad846fb6 New game server:
unc0rr
parents:
diff changeset
    43
		teamowner team,
4e78ad846fb6 New game server:
unc0rr
parents:
diff changeset
    44
		show $ difficulty team
4e78ad846fb6 New game server:
unc0rr
parents:
diff changeset
    45
		]
4e78ad846fb6 New game server:
unc0rr
parents:
diff changeset
    46
		++ hhsInfo
4e78ad846fb6 New game server:
unc0rr
parents:
diff changeset
    47
	where
4e78ad846fb6 New game server:
unc0rr
parents:
diff changeset
    48
		hhsInfo = concatMap (\(HedgehogInfo name hat) -> [name, hat]) $ hedgehogs team
4e78ad846fb6 New game server:
unc0rr
parents:
diff changeset
    49
4e78ad846fb6 New game server:
unc0rr
parents:
diff changeset
    50
modifyTeam :: TeamInfo -> RoomInfo -> RoomInfo
4e78ad846fb6 New game server:
unc0rr
parents:
diff changeset
    51
modifyTeam team room = room{teams = replaceTeam team $ teams room}
4e78ad846fb6 New game server:
unc0rr
parents:
diff changeset
    52
	where
4e78ad846fb6 New game server:
unc0rr
parents:
diff changeset
    53
	replaceTeam _ [] = error "modifyTeam: no such team"
4e78ad846fb6 New game server:
unc0rr
parents:
diff changeset
    54
	replaceTeam team (t:teams) =
4e78ad846fb6 New game server:
unc0rr
parents:
diff changeset
    55
		if teamname team == teamname t then
4e78ad846fb6 New game server:
unc0rr
parents:
diff changeset
    56
			team : teams
4e78ad846fb6 New game server:
unc0rr
parents:
diff changeset
    57
		else
4e78ad846fb6 New game server:
unc0rr
parents:
diff changeset
    58
			t : replaceTeam team teams
4e78ad846fb6 New game server:
unc0rr
parents:
diff changeset
    59
4e78ad846fb6 New game server:
unc0rr
parents:
diff changeset
    60
protoNumber2ver :: Word16 -> String
4e78ad846fb6 New game server:
unc0rr
parents:
diff changeset
    61
protoNumber2ver 17 = "0.9.7-dev"
4e78ad846fb6 New game server:
unc0rr
parents:
diff changeset
    62
protoNumber2ver 19 = "0.9.7"
4e78ad846fb6 New game server:
unc0rr
parents:
diff changeset
    63
protoNumber2ver 20 = "0.9.8-dev"
4e78ad846fb6 New game server:
unc0rr
parents:
diff changeset
    64
protoNumber2ver 21 = "0.9.8"
4e78ad846fb6 New game server:
unc0rr
parents:
diff changeset
    65
protoNumber2ver 22 = "0.9.9-dev"
4e78ad846fb6 New game server:
unc0rr
parents:
diff changeset
    66
protoNumber2ver 23 = "0.9.9"
4e78ad846fb6 New game server:
unc0rr
parents:
diff changeset
    67
protoNumber2ver 24 = "0.9.10-dev"
4e78ad846fb6 New game server:
unc0rr
parents:
diff changeset
    68
protoNumber2ver 25 = "0.9.10"
1953
fd9c8e3c734d Add a special message for old hedgewars versions
unc0rr
parents: 1917
diff changeset
    69
protoNumber2ver 26 = "0.9.11-dev"
1804
4e78ad846fb6 New game server:
unc0rr
parents:
diff changeset
    70
protoNumber2ver _ = "Unknown"
4e78ad846fb6 New game server:
unc0rr
parents:
diff changeset
    71
1964
dc9ea05c9d2f - Another way of defining official server
unc0rr
parents: 1953
diff changeset
    72
askFromConsole :: String -> IO String
dc9ea05c9d2f - Another way of defining official server
unc0rr
parents: 1953
diff changeset
    73
askFromConsole msg = do
dc9ea05c9d2f - Another way of defining official server
unc0rr
parents: 1953
diff changeset
    74
	putStr msg
dc9ea05c9d2f - Another way of defining official server
unc0rr
parents: 1953
diff changeset
    75
	hFlush stdout
dc9ea05c9d2f - Another way of defining official server
unc0rr
parents: 1953
diff changeset
    76
	getLine