gameServer/Utils.hs
author nemo
Sun, 24 Jan 2010 16:46:06 +0000
changeset 2712 8f4527c9137c
parent 2448 30b4a7c8e9b2
child 2747 7889a3a9724f
permissions -rw-r--r--
Minor tweak, try to make long flavour text last longer, move the hurt self messages to unused messages group, so they don't get wiped by crate an instant later.
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
2349
ba7a0813c532 Some fixes suggested by hlint
unc0rr
parents: 2310
diff changeset
    15
import Control.Monad
2304
a6e733ad0366 Implement filtering in server
unc0rr
parents: 2150
diff changeset
    16
import Maybe
1804
4e78ad846fb6 New game server:
unc0rr
parents:
diff changeset
    17
-------------------------------------------------
4e78ad846fb6 New game server:
unc0rr
parents:
diff changeset
    18
import qualified Codec.Binary.Base64 as Base64
4e78ad846fb6 New game server:
unc0rr
parents:
diff changeset
    19
import qualified Codec.Binary.UTF8.String as UTF8
4e78ad846fb6 New game server:
unc0rr
parents:
diff changeset
    20
import CoreTypes
4e78ad846fb6 New game server:
unc0rr
parents:
diff changeset
    21
1917
c94045b70142 - Better ip2string implementation
unc0rr
parents: 1804
diff changeset
    22
c94045b70142 - Better ip2string implementation
unc0rr
parents: 1804
diff changeset
    23
sockAddr2String :: SockAddr -> IO String
c94045b70142 - Better ip2string implementation
unc0rr
parents: 1804
diff changeset
    24
sockAddr2String (SockAddrInet _ hostAddr) = inet_ntoa hostAddr
c94045b70142 - Better ip2string implementation
unc0rr
parents: 1804
diff changeset
    25
sockAddr2String (SockAddrInet6 _ _ (a, b, c, d) _) =
c94045b70142 - Better ip2string implementation
unc0rr
parents: 1804
diff changeset
    26
	return $ (foldr1 (.)
c94045b70142 - Better ip2string implementation
unc0rr
parents: 1804
diff changeset
    27
		$ List.intersperse (\a -> ':':a)
c94045b70142 - Better ip2string implementation
unc0rr
parents: 1804
diff changeset
    28
		$ concatMap (\n -> (\(a, b) -> [showHex a, showHex b]) $ divMod n 65536) [a, b, c, d]) []
c94045b70142 - Better ip2string implementation
unc0rr
parents: 1804
diff changeset
    29
1804
4e78ad846fb6 New game server:
unc0rr
parents:
diff changeset
    30
toEngineMsg :: String -> String
2403
6c5d504af2ba - Proper /team command implementation
unc0rr
parents: 2381
diff changeset
    31
toEngineMsg msg = Base64.encode (fromIntegral (length encodedMsg) : encodedMsg)
6c5d504af2ba - Proper /team command implementation
unc0rr
parents: 2381
diff changeset
    32
	where
6c5d504af2ba - Proper /team command implementation
unc0rr
parents: 2381
diff changeset
    33
	encodedMsg = UTF8.encode msg
1804
4e78ad846fb6 New game server:
unc0rr
parents:
diff changeset
    34
2304
a6e733ad0366 Implement filtering in server
unc0rr
parents: 2150
diff changeset
    35
fromEngineMsg :: String -> Maybe String
2349
ba7a0813c532 Some fixes suggested by hlint
unc0rr
parents: 2310
diff changeset
    36
fromEngineMsg msg = liftM (map w2c) (Base64.decode msg >>= removeLength)
2304
a6e733ad0366 Implement filtering in server
unc0rr
parents: 2150
diff changeset
    37
	where
2310
581e59f123a2 Fix filtering
unc0rr
parents: 2309
diff changeset
    38
		removeLength (x:xs) = if length xs == fromIntegral x then Just xs else Nothing
2304
a6e733ad0366 Implement filtering in server
unc0rr
parents: 2150
diff changeset
    39
		removeLength _ = Nothing
a6e733ad0366 Implement filtering in server
unc0rr
parents: 2150
diff changeset
    40
2381
959da8402cac Don't store keepalive messages in game server spectators buffer
unc0rr
parents: 2349
diff changeset
    41
checkNetCmd :: String -> (Bool, Bool)
959da8402cac Don't store keepalive messages in game server spectators buffer
unc0rr
parents: 2349
diff changeset
    42
checkNetCmd msg = check decoded
2304
a6e733ad0366 Implement filtering in server
unc0rr
parents: 2150
diff changeset
    43
	where
a6e733ad0366 Implement filtering in server
unc0rr
parents: 2150
diff changeset
    44
		decoded = fromEngineMsg msg
2381
959da8402cac Don't store keepalive messages in game server spectators buffer
unc0rr
parents: 2349
diff changeset
    45
		check Nothing = (False, False)
959da8402cac Don't store keepalive messages in game server spectators buffer
unc0rr
parents: 2349
diff changeset
    46
		check (Just (m:ms)) = (m `Set.member` legalMessages, m == '+')
959da8402cac Don't store keepalive messages in game server spectators buffer
unc0rr
parents: 2349
diff changeset
    47
		check _ = (False, False)
2309
1c106b0d36da Don't filter +left command :D
unc0rr
parents: 2305
diff changeset
    48
		legalMessages = Set.fromList $ "M#+LlRrUuDdZzAaSjJ,sFNpPwtghb12345" ++ slotMessages
2349
ba7a0813c532 Some fixes suggested by hlint
unc0rr
parents: 2310
diff changeset
    49
		slotMessages = "\128\129\130\131\132\133\134\135\136\137\138"
1804
4e78ad846fb6 New game server:
unc0rr
parents:
diff changeset
    50
4e78ad846fb6 New game server:
unc0rr
parents:
diff changeset
    51
maybeRead :: Read a => String -> Maybe a
4e78ad846fb6 New game server:
unc0rr
parents:
diff changeset
    52
maybeRead s = case reads s of
4e78ad846fb6 New game server:
unc0rr
parents:
diff changeset
    53
	[(x, rest)] | all isSpace rest -> Just x
4e78ad846fb6 New game server:
unc0rr
parents:
diff changeset
    54
	_         -> Nothing
4e78ad846fb6 New game server:
unc0rr
parents:
diff changeset
    55
4e78ad846fb6 New game server:
unc0rr
parents:
diff changeset
    56
teamToNet team = [
4e78ad846fb6 New game server:
unc0rr
parents:
diff changeset
    57
		"ADD_TEAM",
4e78ad846fb6 New game server:
unc0rr
parents:
diff changeset
    58
		teamname team,
4e78ad846fb6 New game server:
unc0rr
parents:
diff changeset
    59
		teamgrave team,
4e78ad846fb6 New game server:
unc0rr
parents:
diff changeset
    60
		teamfort team,
4e78ad846fb6 New game server:
unc0rr
parents:
diff changeset
    61
		teamvoicepack team,
4e78ad846fb6 New game server:
unc0rr
parents:
diff changeset
    62
		teamowner team,
4e78ad846fb6 New game server:
unc0rr
parents:
diff changeset
    63
		show $ difficulty team
4e78ad846fb6 New game server:
unc0rr
parents:
diff changeset
    64
		]
4e78ad846fb6 New game server:
unc0rr
parents:
diff changeset
    65
		++ hhsInfo
4e78ad846fb6 New game server:
unc0rr
parents:
diff changeset
    66
	where
4e78ad846fb6 New game server:
unc0rr
parents:
diff changeset
    67
		hhsInfo = concatMap (\(HedgehogInfo name hat) -> [name, hat]) $ hedgehogs team
4e78ad846fb6 New game server:
unc0rr
parents:
diff changeset
    68
4e78ad846fb6 New game server:
unc0rr
parents:
diff changeset
    69
modifyTeam :: TeamInfo -> RoomInfo -> RoomInfo
4e78ad846fb6 New game server:
unc0rr
parents:
diff changeset
    70
modifyTeam team room = room{teams = replaceTeam team $ teams room}
4e78ad846fb6 New game server:
unc0rr
parents:
diff changeset
    71
	where
4e78ad846fb6 New game server:
unc0rr
parents:
diff changeset
    72
	replaceTeam _ [] = error "modifyTeam: no such team"
4e78ad846fb6 New game server:
unc0rr
parents:
diff changeset
    73
	replaceTeam team (t:teams) =
4e78ad846fb6 New game server:
unc0rr
parents:
diff changeset
    74
		if teamname team == teamname t then
4e78ad846fb6 New game server:
unc0rr
parents:
diff changeset
    75
			team : teams
4e78ad846fb6 New game server:
unc0rr
parents:
diff changeset
    76
		else
4e78ad846fb6 New game server:
unc0rr
parents:
diff changeset
    77
			t : replaceTeam team teams
4e78ad846fb6 New game server:
unc0rr
parents:
diff changeset
    78
2150
45b695f3a7b9 Forbid room names and nicknames consisting only of space characters
unc0rr
parents: 2113
diff changeset
    79
illegalName :: String -> Bool
2349
ba7a0813c532 Some fixes suggested by hlint
unc0rr
parents: 2310
diff changeset
    80
illegalName = all isSpace
2150
45b695f3a7b9 Forbid room names and nicknames consisting only of space characters
unc0rr
parents: 2113
diff changeset
    81
1804
4e78ad846fb6 New game server:
unc0rr
parents:
diff changeset
    82
protoNumber2ver :: Word16 -> String
4e78ad846fb6 New game server:
unc0rr
parents:
diff changeset
    83
protoNumber2ver 17 = "0.9.7-dev"
4e78ad846fb6 New game server:
unc0rr
parents:
diff changeset
    84
protoNumber2ver 19 = "0.9.7"
4e78ad846fb6 New game server:
unc0rr
parents:
diff changeset
    85
protoNumber2ver 20 = "0.9.8-dev"
4e78ad846fb6 New game server:
unc0rr
parents:
diff changeset
    86
protoNumber2ver 21 = "0.9.8"
4e78ad846fb6 New game server:
unc0rr
parents:
diff changeset
    87
protoNumber2ver 22 = "0.9.9-dev"
4e78ad846fb6 New game server:
unc0rr
parents:
diff changeset
    88
protoNumber2ver 23 = "0.9.9"
4e78ad846fb6 New game server:
unc0rr
parents:
diff changeset
    89
protoNumber2ver 24 = "0.9.10-dev"
4e78ad846fb6 New game server:
unc0rr
parents:
diff changeset
    90
protoNumber2ver 25 = "0.9.10"
1953
fd9c8e3c734d Add a special message for old hedgewars versions
unc0rr
parents: 1917
diff changeset
    91
protoNumber2ver 26 = "0.9.11-dev"
2113
89d0fa6734af Update server protocol number to version mapping
unc0rr
parents: 1964
diff changeset
    92
protoNumber2ver 27 = "0.9.11"
89d0fa6734af Update server protocol number to version mapping
unc0rr
parents: 1964
diff changeset
    93
protoNumber2ver 28 = "0.9.12-dev"
2448
30b4a7c8e9b2 Teach server to know 0.9.12 and 0.9.13-dev
unc0rr
parents: 2403
diff changeset
    94
protoNumber2ver 29 = "0.9.12"
30b4a7c8e9b2 Teach server to know 0.9.12 and 0.9.13-dev
unc0rr
parents: 2403
diff changeset
    95
protoNumber2ver 30 = "0.9.13-dev"
1804
4e78ad846fb6 New game server:
unc0rr
parents:
diff changeset
    96
protoNumber2ver _ = "Unknown"
4e78ad846fb6 New game server:
unc0rr
parents:
diff changeset
    97
1964
dc9ea05c9d2f - Another way of defining official server
unc0rr
parents: 1953
diff changeset
    98
askFromConsole :: String -> IO String
dc9ea05c9d2f - Another way of defining official server
unc0rr
parents: 1953
diff changeset
    99
askFromConsole msg = do
dc9ea05c9d2f - Another way of defining official server
unc0rr
parents: 1953
diff changeset
   100
	putStr msg
dc9ea05c9d2f - Another way of defining official server
unc0rr
parents: 1953
diff changeset
   101
	hFlush stdout
dc9ea05c9d2f - Another way of defining official server
unc0rr
parents: 1953
diff changeset
   102
	getLine