gameServer/Utils.hs
author unc0rr
Sat, 15 Aug 2009 09:34:31 +0000
changeset 2312 3b59f1251ead
parent 2310 581e59f123a2
child 2349 ba7a0813c532
permissions -rw-r--r--
Bind zoom in/out to [ and ]
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
2304
a6e733ad0366 Implement filtering in server
unc0rr
parents: 2150
diff changeset
     9
import qualified Data.Set as Set
2310
581e59f123a2 Fix filtering
unc0rr
parents: 2309
diff changeset
    10
import Data.ByteString.Internal (w2c)
1917
c94045b70142 - Better ip2string implementation
unc0rr
parents: 1804
diff changeset
    11
import Numeric
c94045b70142 - Better ip2string implementation
unc0rr
parents: 1804
diff changeset
    12
import Network.Socket
1964
dc9ea05c9d2f - Another way of defining official server
unc0rr
parents: 1953
diff changeset
    13
import System.IO
1917
c94045b70142 - Better ip2string implementation
unc0rr
parents: 1804
diff changeset
    14
import qualified Data.List as List
2304
a6e733ad0366 Implement filtering in server
unc0rr
parents: 2150
diff changeset
    15
import Maybe
1804
4e78ad846fb6 New game server:
unc0rr
parents:
diff changeset
    16
-------------------------------------------------
4e78ad846fb6 New game server:
unc0rr
parents:
diff changeset
    17
import qualified Codec.Binary.Base64 as Base64
4e78ad846fb6 New game server:
unc0rr
parents:
diff changeset
    18
import qualified Codec.Binary.UTF8.String as UTF8
4e78ad846fb6 New game server:
unc0rr
parents:
diff changeset
    19
import CoreTypes
4e78ad846fb6 New game server:
unc0rr
parents:
diff changeset
    20
1917
c94045b70142 - Better ip2string implementation
unc0rr
parents: 1804
diff changeset
    21
c94045b70142 - Better ip2string implementation
unc0rr
parents: 1804
diff changeset
    22
sockAddr2String :: SockAddr -> IO String
c94045b70142 - Better ip2string implementation
unc0rr
parents: 1804
diff changeset
    23
sockAddr2String (SockAddrInet _ hostAddr) = inet_ntoa hostAddr
c94045b70142 - Better ip2string implementation
unc0rr
parents: 1804
diff changeset
    24
sockAddr2String (SockAddrInet6 _ _ (a, b, c, d) _) =
c94045b70142 - Better ip2string implementation
unc0rr
parents: 1804
diff changeset
    25
	return $ (foldr1 (.)
c94045b70142 - Better ip2string implementation
unc0rr
parents: 1804
diff changeset
    26
		$ List.intersperse (\a -> ':':a)
c94045b70142 - Better ip2string implementation
unc0rr
parents: 1804
diff changeset
    27
		$ concatMap (\n -> (\(a, b) -> [showHex a, showHex b]) $ divMod n 65536) [a, b, c, d]) []
c94045b70142 - Better ip2string implementation
unc0rr
parents: 1804
diff changeset
    28
1804
4e78ad846fb6 New game server:
unc0rr
parents:
diff changeset
    29
toEngineMsg :: String -> String
4e78ad846fb6 New game server:
unc0rr
parents:
diff changeset
    30
toEngineMsg msg = Base64.encode (fromIntegral (length msg) : (UTF8.encode msg))
4e78ad846fb6 New game server:
unc0rr
parents:
diff changeset
    31
2304
a6e733ad0366 Implement filtering in server
unc0rr
parents: 2150
diff changeset
    32
fromEngineMsg :: String -> Maybe String
2310
581e59f123a2 Fix filtering
unc0rr
parents: 2309
diff changeset
    33
fromEngineMsg msg = Base64.decode msg >>= removeLength >>= return . (map w2c)
2304
a6e733ad0366 Implement filtering in server
unc0rr
parents: 2150
diff changeset
    34
	where
2310
581e59f123a2 Fix filtering
unc0rr
parents: 2309
diff changeset
    35
		removeLength (x:xs) = if length xs == fromIntegral x then Just xs else Nothing
2304
a6e733ad0366 Implement filtering in server
unc0rr
parents: 2150
diff changeset
    36
		removeLength _ = Nothing
a6e733ad0366 Implement filtering in server
unc0rr
parents: 2150
diff changeset
    37
a6e733ad0366 Implement filtering in server
unc0rr
parents: 2150
diff changeset
    38
isLegalNetCommand :: String -> Bool
a6e733ad0366 Implement filtering in server
unc0rr
parents: 2150
diff changeset
    39
isLegalNetCommand msg = test decoded
a6e733ad0366 Implement filtering in server
unc0rr
parents: 2150
diff changeset
    40
	where
a6e733ad0366 Implement filtering in server
unc0rr
parents: 2150
diff changeset
    41
		decoded = fromEngineMsg msg
a6e733ad0366 Implement filtering in server
unc0rr
parents: 2150
diff changeset
    42
		test Nothing = False
a6e733ad0366 Implement filtering in server
unc0rr
parents: 2150
diff changeset
    43
		test (Just (m:ms)) = m `Set.member` legalMessages
2305
a51f5f88f3cf reorganize functions a bit
unc0rr
parents: 2304
diff changeset
    44
		test _ = False
2309
1c106b0d36da Don't filter +left command :D
unc0rr
parents: 2305
diff changeset
    45
		legalMessages = Set.fromList $ "M#+LlRrUuDdZzAaSjJ,sFNpPwtghb12345" ++ slotMessages
2304
a6e733ad0366 Implement filtering in server
unc0rr
parents: 2150
diff changeset
    46
		slotMessages = ['\128', '\129', '\130', '\131', '\132', '\133', '\134', '\135', '\136', '\137', '\138']
1804
4e78ad846fb6 New game server:
unc0rr
parents:
diff changeset
    47
4e78ad846fb6 New game server:
unc0rr
parents:
diff changeset
    48
maybeRead :: Read a => String -> Maybe a
4e78ad846fb6 New game server:
unc0rr
parents:
diff changeset
    49
maybeRead s = case reads s of
4e78ad846fb6 New game server:
unc0rr
parents:
diff changeset
    50
	[(x, rest)] | all isSpace rest -> Just x
4e78ad846fb6 New game server:
unc0rr
parents:
diff changeset
    51
	_         -> Nothing
4e78ad846fb6 New game server:
unc0rr
parents:
diff changeset
    52
4e78ad846fb6 New game server:
unc0rr
parents:
diff changeset
    53
teamToNet team = [
4e78ad846fb6 New game server:
unc0rr
parents:
diff changeset
    54
		"ADD_TEAM",
4e78ad846fb6 New game server:
unc0rr
parents:
diff changeset
    55
		teamname team,
4e78ad846fb6 New game server:
unc0rr
parents:
diff changeset
    56
		teamgrave team,
4e78ad846fb6 New game server:
unc0rr
parents:
diff changeset
    57
		teamfort team,
4e78ad846fb6 New game server:
unc0rr
parents:
diff changeset
    58
		teamvoicepack team,
4e78ad846fb6 New game server:
unc0rr
parents:
diff changeset
    59
		teamowner team,
4e78ad846fb6 New game server:
unc0rr
parents:
diff changeset
    60
		show $ difficulty team
4e78ad846fb6 New game server:
unc0rr
parents:
diff changeset
    61
		]
4e78ad846fb6 New game server:
unc0rr
parents:
diff changeset
    62
		++ hhsInfo
4e78ad846fb6 New game server:
unc0rr
parents:
diff changeset
    63
	where
4e78ad846fb6 New game server:
unc0rr
parents:
diff changeset
    64
		hhsInfo = concatMap (\(HedgehogInfo name hat) -> [name, hat]) $ hedgehogs team
4e78ad846fb6 New game server:
unc0rr
parents:
diff changeset
    65
4e78ad846fb6 New game server:
unc0rr
parents:
diff changeset
    66
modifyTeam :: TeamInfo -> RoomInfo -> RoomInfo
4e78ad846fb6 New game server:
unc0rr
parents:
diff changeset
    67
modifyTeam team room = room{teams = replaceTeam team $ teams room}
4e78ad846fb6 New game server:
unc0rr
parents:
diff changeset
    68
	where
4e78ad846fb6 New game server:
unc0rr
parents:
diff changeset
    69
	replaceTeam _ [] = error "modifyTeam: no such team"
4e78ad846fb6 New game server:
unc0rr
parents:
diff changeset
    70
	replaceTeam team (t:teams) =
4e78ad846fb6 New game server:
unc0rr
parents:
diff changeset
    71
		if teamname team == teamname t then
4e78ad846fb6 New game server:
unc0rr
parents:
diff changeset
    72
			team : teams
4e78ad846fb6 New game server:
unc0rr
parents:
diff changeset
    73
		else
4e78ad846fb6 New game server:
unc0rr
parents:
diff changeset
    74
			t : replaceTeam team teams
4e78ad846fb6 New game server:
unc0rr
parents:
diff changeset
    75
2150
45b695f3a7b9 Forbid room names and nicknames consisting only of space characters
unc0rr
parents: 2113
diff changeset
    76
illegalName :: String -> Bool
45b695f3a7b9 Forbid room names and nicknames consisting only of space characters
unc0rr
parents: 2113
diff changeset
    77
illegalName str = all isSpace str
45b695f3a7b9 Forbid room names and nicknames consisting only of space characters
unc0rr
parents: 2113
diff changeset
    78
1804
4e78ad846fb6 New game server:
unc0rr
parents:
diff changeset
    79
protoNumber2ver :: Word16 -> String
4e78ad846fb6 New game server:
unc0rr
parents:
diff changeset
    80
protoNumber2ver 17 = "0.9.7-dev"
4e78ad846fb6 New game server:
unc0rr
parents:
diff changeset
    81
protoNumber2ver 19 = "0.9.7"
4e78ad846fb6 New game server:
unc0rr
parents:
diff changeset
    82
protoNumber2ver 20 = "0.9.8-dev"
4e78ad846fb6 New game server:
unc0rr
parents:
diff changeset
    83
protoNumber2ver 21 = "0.9.8"
4e78ad846fb6 New game server:
unc0rr
parents:
diff changeset
    84
protoNumber2ver 22 = "0.9.9-dev"
4e78ad846fb6 New game server:
unc0rr
parents:
diff changeset
    85
protoNumber2ver 23 = "0.9.9"
4e78ad846fb6 New game server:
unc0rr
parents:
diff changeset
    86
protoNumber2ver 24 = "0.9.10-dev"
4e78ad846fb6 New game server:
unc0rr
parents:
diff changeset
    87
protoNumber2ver 25 = "0.9.10"
1953
fd9c8e3c734d Add a special message for old hedgewars versions
unc0rr
parents: 1917
diff changeset
    88
protoNumber2ver 26 = "0.9.11-dev"
2113
89d0fa6734af Update server protocol number to version mapping
unc0rr
parents: 1964
diff changeset
    89
protoNumber2ver 27 = "0.9.11"
89d0fa6734af Update server protocol number to version mapping
unc0rr
parents: 1964
diff changeset
    90
protoNumber2ver 28 = "0.9.12-dev"
1804
4e78ad846fb6 New game server:
unc0rr
parents:
diff changeset
    91
protoNumber2ver _ = "Unknown"
4e78ad846fb6 New game server:
unc0rr
parents:
diff changeset
    92
1964
dc9ea05c9d2f - Another way of defining official server
unc0rr
parents: 1953
diff changeset
    93
askFromConsole :: String -> IO String
dc9ea05c9d2f - Another way of defining official server
unc0rr
parents: 1953
diff changeset
    94
askFromConsole msg = do
dc9ea05c9d2f - Another way of defining official server
unc0rr
parents: 1953
diff changeset
    95
	putStr msg
dc9ea05c9d2f - Another way of defining official server
unc0rr
parents: 1953
diff changeset
    96
	hFlush stdout
dc9ea05c9d2f - Another way of defining official server
unc0rr
parents: 1953
diff changeset
    97
	getLine