gameServer/Utils.hs
author nemo
Sun, 26 Dec 2010 00:28:23 -0500
changeset 4686 3682db294dae
parent 4570 fa19f0579083
child 4693 6f74c97147fe
permissions -rw-r--r--
remove all screwing about with uLandGraphics - have not found a way to properly handle LandBackTex through despeckling or fill checks that does not result in ugly fire damage or wiped out landbacktex. Would rather some snowflakes lines than that.
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
4295
1f5604cd99be This revision should, in theory, correctly merge 0.9.14 and tip, so that future merges of 0.9.14 should work properly
nemo
parents: 4242
diff changeset
    16
import Data.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
4568
f85243bf890e Ok. This should pull 0.9.14.1 server into default
nemo
parents: 4337
diff changeset
    19
import qualified Data.ByteString.UTF8 as BUTF8
f85243bf890e Ok. This should pull 0.9.14.1 server into default
nemo
parents: 4337
diff changeset
    20
import qualified Data.ByteString as B
1804
4e78ad846fb6 New game server:
unc0rr
parents:
diff changeset
    21
import CoreTypes
4e78ad846fb6 New game server:
unc0rr
parents:
diff changeset
    22
1917
c94045b70142 - Better ip2string implementation
unc0rr
parents: 1804
diff changeset
    23
4568
f85243bf890e Ok. This should pull 0.9.14.1 server into default
nemo
parents: 4337
diff changeset
    24
sockAddr2String :: SockAddr -> IO String
f85243bf890e Ok. This should pull 0.9.14.1 server into default
nemo
parents: 4337
diff changeset
    25
sockAddr2String (SockAddrInet _ hostAddr) = inet_ntoa hostAddr
1917
c94045b70142 - Better ip2string implementation
unc0rr
parents: 1804
diff changeset
    26
sockAddr2String (SockAddrInet6 _ _ (a, b, c, d) _) =
4568
f85243bf890e Ok. This should pull 0.9.14.1 server into default
nemo
parents: 4337
diff changeset
    27
    return $ (foldr1 (.)
2867
9be6693c78cb - Unbreak support for client versions prior to 0.9.13-dev
unc0rr
parents: 2747
diff changeset
    28
        $ List.intersperse (\a -> ':':a)
9be6693c78cb - Unbreak support for client versions prior to 0.9.13-dev
unc0rr
parents: 2747
diff changeset
    29
        $ concatMap (\n -> (\(a, b) -> [showHex a, showHex b]) $ divMod n 65536) [a, b, c, d]) []
1917
c94045b70142 - Better ip2string implementation
unc0rr
parents: 1804
diff changeset
    30
4568
f85243bf890e Ok. This should pull 0.9.14.1 server into default
nemo
parents: 4337
diff changeset
    31
toEngineMsg :: String -> String
f85243bf890e Ok. This should pull 0.9.14.1 server into default
nemo
parents: 4337
diff changeset
    32
toEngineMsg msg = Base64.encode (fromIntegral (B.length encodedMsg) : (B.unpack encodedMsg))
f85243bf890e Ok. This should pull 0.9.14.1 server into default
nemo
parents: 4337
diff changeset
    33
    where
f85243bf890e Ok. This should pull 0.9.14.1 server into default
nemo
parents: 4337
diff changeset
    34
    encodedMsg = BUTF8.fromString msg
1804
4e78ad846fb6 New game server:
unc0rr
parents:
diff changeset
    35
4568
f85243bf890e Ok. This should pull 0.9.14.1 server into default
nemo
parents: 4337
diff changeset
    36
fromEngineMsg :: String -> Maybe String
f85243bf890e Ok. This should pull 0.9.14.1 server into default
nemo
parents: 4337
diff changeset
    37
fromEngineMsg msg = liftM (map w2c) (Base64.decode msg >>= removeLength)
2867
9be6693c78cb - Unbreak support for client versions prior to 0.9.13-dev
unc0rr
parents: 2747
diff changeset
    38
    where
9be6693c78cb - Unbreak support for client versions prior to 0.9.13-dev
unc0rr
parents: 2747
diff changeset
    39
        removeLength (x:xs) = if length xs == fromIntegral x then Just xs else Nothing
9be6693c78cb - Unbreak support for client versions prior to 0.9.13-dev
unc0rr
parents: 2747
diff changeset
    40
        removeLength _ = Nothing
2304
a6e733ad0366 Implement filtering in server
unc0rr
parents: 2150
diff changeset
    41
4568
f85243bf890e Ok. This should pull 0.9.14.1 server into default
nemo
parents: 4337
diff changeset
    42
checkNetCmd :: String -> (Bool, Bool)
f85243bf890e Ok. This should pull 0.9.14.1 server into default
nemo
parents: 4337
diff changeset
    43
checkNetCmd msg = check decoded
2867
9be6693c78cb - Unbreak support for client versions prior to 0.9.13-dev
unc0rr
parents: 2747
diff changeset
    44
    where
4568
f85243bf890e Ok. This should pull 0.9.14.1 server into default
nemo
parents: 4337
diff changeset
    45
        decoded = fromEngineMsg msg
2867
9be6693c78cb - Unbreak support for client versions prior to 0.9.13-dev
unc0rr
parents: 2747
diff changeset
    46
        check Nothing = (False, False)
9be6693c78cb - Unbreak support for client versions prior to 0.9.13-dev
unc0rr
parents: 2747
diff changeset
    47
        check (Just (m:ms)) = (m `Set.member` legalMessages, m == '+')
9be6693c78cb - Unbreak support for client versions prior to 0.9.13-dev
unc0rr
parents: 2747
diff changeset
    48
        check _ = (False, False)
4570
fa19f0579083 Merge unc0rr's rearranging of MAP/MAPGEN messages, also his suggested increase of char limit to 20000 and addition of the "c" game message
nemo
parents: 4568
diff changeset
    49
        legalMessages = Set.fromList $ "M#+LlRrUuDdZzAaSjJ,sFNpPwtghbc12345" ++ slotMessages
2867
9be6693c78cb - Unbreak support for client versions prior to 0.9.13-dev
unc0rr
parents: 2747
diff changeset
    50
        slotMessages = "\128\129\130\131\132\133\134\135\136\137\138"
1804
4e78ad846fb6 New game server:
unc0rr
parents:
diff changeset
    51
4e78ad846fb6 New game server:
unc0rr
parents:
diff changeset
    52
maybeRead :: Read a => String -> Maybe a
4e78ad846fb6 New game server:
unc0rr
parents:
diff changeset
    53
maybeRead s = case reads s of
2867
9be6693c78cb - Unbreak support for client versions prior to 0.9.13-dev
unc0rr
parents: 2747
diff changeset
    54
    [(x, rest)] | all isSpace rest -> Just x
9be6693c78cb - Unbreak support for client versions prior to 0.9.13-dev
unc0rr
parents: 2747
diff changeset
    55
    _         -> Nothing
1804
4e78ad846fb6 New game server:
unc0rr
parents:
diff changeset
    56
4568
f85243bf890e Ok. This should pull 0.9.14.1 server into default
nemo
parents: 4337
diff changeset
    57
teamToNet :: Word16 -> TeamInfo -> [String]
f85243bf890e Ok. This should pull 0.9.14.1 server into default
nemo
parents: 4337
diff changeset
    58
teamToNet protocol team 
f85243bf890e Ok. This should pull 0.9.14.1 server into default
nemo
parents: 4337
diff changeset
    59
    | protocol < 30 = [
f85243bf890e Ok. This should pull 0.9.14.1 server into default
nemo
parents: 4337
diff changeset
    60
        "ADD_TEAM",
f85243bf890e Ok. This should pull 0.9.14.1 server into default
nemo
parents: 4337
diff changeset
    61
        teamname team,
f85243bf890e Ok. This should pull 0.9.14.1 server into default
nemo
parents: 4337
diff changeset
    62
        teamgrave team,
f85243bf890e Ok. This should pull 0.9.14.1 server into default
nemo
parents: 4337
diff changeset
    63
        teamfort team,
f85243bf890e Ok. This should pull 0.9.14.1 server into default
nemo
parents: 4337
diff changeset
    64
        teamvoicepack team,
f85243bf890e Ok. This should pull 0.9.14.1 server into default
nemo
parents: 4337
diff changeset
    65
        teamowner team,
f85243bf890e Ok. This should pull 0.9.14.1 server into default
nemo
parents: 4337
diff changeset
    66
        show $ difficulty team
f85243bf890e Ok. This should pull 0.9.14.1 server into default
nemo
parents: 4337
diff changeset
    67
        ]
f85243bf890e Ok. This should pull 0.9.14.1 server into default
nemo
parents: 4337
diff changeset
    68
        ++ hhsInfo
f85243bf890e Ok. This should pull 0.9.14.1 server into default
nemo
parents: 4337
diff changeset
    69
    | otherwise = [
f85243bf890e Ok. This should pull 0.9.14.1 server into default
nemo
parents: 4337
diff changeset
    70
        "ADD_TEAM",
f85243bf890e Ok. This should pull 0.9.14.1 server into default
nemo
parents: 4337
diff changeset
    71
        teamname team,
f85243bf890e Ok. This should pull 0.9.14.1 server into default
nemo
parents: 4337
diff changeset
    72
        teamgrave team,
f85243bf890e Ok. This should pull 0.9.14.1 server into default
nemo
parents: 4337
diff changeset
    73
        teamfort team,
f85243bf890e Ok. This should pull 0.9.14.1 server into default
nemo
parents: 4337
diff changeset
    74
        teamvoicepack team,
f85243bf890e Ok. This should pull 0.9.14.1 server into default
nemo
parents: 4337
diff changeset
    75
        teamflag team,
f85243bf890e Ok. This should pull 0.9.14.1 server into default
nemo
parents: 4337
diff changeset
    76
        teamowner team,
f85243bf890e Ok. This should pull 0.9.14.1 server into default
nemo
parents: 4337
diff changeset
    77
        show $ difficulty team
f85243bf890e Ok. This should pull 0.9.14.1 server into default
nemo
parents: 4337
diff changeset
    78
        ]
f85243bf890e Ok. This should pull 0.9.14.1 server into default
nemo
parents: 4337
diff changeset
    79
        ++ hhsInfo
2867
9be6693c78cb - Unbreak support for client versions prior to 0.9.13-dev
unc0rr
parents: 2747
diff changeset
    80
    where
9be6693c78cb - Unbreak support for client versions prior to 0.9.13-dev
unc0rr
parents: 2747
diff changeset
    81
        hhsInfo = concatMap (\(HedgehogInfo name hat) -> [name, hat]) $ hedgehogs team
1804
4e78ad846fb6 New game server:
unc0rr
parents:
diff changeset
    82
4e78ad846fb6 New game server:
unc0rr
parents:
diff changeset
    83
modifyTeam :: TeamInfo -> RoomInfo -> RoomInfo
4e78ad846fb6 New game server:
unc0rr
parents:
diff changeset
    84
modifyTeam team room = room{teams = replaceTeam team $ teams room}
2867
9be6693c78cb - Unbreak support for client versions prior to 0.9.13-dev
unc0rr
parents: 2747
diff changeset
    85
    where
9be6693c78cb - Unbreak support for client versions prior to 0.9.13-dev
unc0rr
parents: 2747
diff changeset
    86
    replaceTeam _ [] = error "modifyTeam: no such team"
9be6693c78cb - Unbreak support for client versions prior to 0.9.13-dev
unc0rr
parents: 2747
diff changeset
    87
    replaceTeam team (t:teams) =
9be6693c78cb - Unbreak support for client versions prior to 0.9.13-dev
unc0rr
parents: 2747
diff changeset
    88
        if teamname team == teamname t then
9be6693c78cb - Unbreak support for client versions prior to 0.9.13-dev
unc0rr
parents: 2747
diff changeset
    89
            team : teams
9be6693c78cb - Unbreak support for client versions prior to 0.9.13-dev
unc0rr
parents: 2747
diff changeset
    90
        else
9be6693c78cb - Unbreak support for client versions prior to 0.9.13-dev
unc0rr
parents: 2747
diff changeset
    91
            t : replaceTeam team teams
1804
4e78ad846fb6 New game server:
unc0rr
parents:
diff changeset
    92
4568
f85243bf890e Ok. This should pull 0.9.14.1 server into default
nemo
parents: 4337
diff changeset
    93
illegalName :: String -> Bool
f85243bf890e Ok. This should pull 0.9.14.1 server into default
nemo
parents: 4337
diff changeset
    94
illegalName = all isSpace
2150
45b695f3a7b9 Forbid room names and nicknames consisting only of space characters
unc0rr
parents: 2113
diff changeset
    95
4568
f85243bf890e Ok. This should pull 0.9.14.1 server into default
nemo
parents: 4337
diff changeset
    96
protoNumber2ver :: Word16 -> String
1804
4e78ad846fb6 New game server:
unc0rr
parents:
diff changeset
    97
protoNumber2ver 17 = "0.9.7-dev"
4e78ad846fb6 New game server:
unc0rr
parents:
diff changeset
    98
protoNumber2ver 19 = "0.9.7"
4e78ad846fb6 New game server:
unc0rr
parents:
diff changeset
    99
protoNumber2ver 20 = "0.9.8-dev"
4e78ad846fb6 New game server:
unc0rr
parents:
diff changeset
   100
protoNumber2ver 21 = "0.9.8"
4e78ad846fb6 New game server:
unc0rr
parents:
diff changeset
   101
protoNumber2ver 22 = "0.9.9-dev"
4e78ad846fb6 New game server:
unc0rr
parents:
diff changeset
   102
protoNumber2ver 23 = "0.9.9"
4e78ad846fb6 New game server:
unc0rr
parents:
diff changeset
   103
protoNumber2ver 24 = "0.9.10-dev"
4e78ad846fb6 New game server:
unc0rr
parents:
diff changeset
   104
protoNumber2ver 25 = "0.9.10"
1953
fd9c8e3c734d Add a special message for old hedgewars versions
unc0rr
parents: 1917
diff changeset
   105
protoNumber2ver 26 = "0.9.11-dev"
2113
89d0fa6734af Update server protocol number to version mapping
unc0rr
parents: 1964
diff changeset
   106
protoNumber2ver 27 = "0.9.11"
89d0fa6734af Update server protocol number to version mapping
unc0rr
parents: 1964
diff changeset
   107
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
   108
protoNumber2ver 29 = "0.9.12"
30b4a7c8e9b2 Teach server to know 0.9.12 and 0.9.13-dev
unc0rr
parents: 2403
diff changeset
   109
protoNumber2ver 30 = "0.9.13-dev"
3297
0c59b991007e 31 is 0.9.13
unc0rr
parents: 2952
diff changeset
   110
protoNumber2ver 31 = "0.9.13"
0c59b991007e 31 is 0.9.13
unc0rr
parents: 2952
diff changeset
   111
protoNumber2ver 32 = "0.9.14-dev"
4266
bc6e9859f142 Add 0.9.14 and 0.9.15-dev mapping
unC0Rr
parents: 4242
diff changeset
   112
protoNumber2ver 33 = "0.9.14"
bc6e9859f142 Add 0.9.14 and 0.9.15-dev mapping
unC0Rr
parents: 4242
diff changeset
   113
protoNumber2ver 34 = "0.9.15-dev"
4326
85adae559981 35 -> 0.9.14.1 mapping
unc0rr
parents: 4266
diff changeset
   114
protoNumber2ver 35 = "0.9.14.1"
1804
4e78ad846fb6 New game server:
unc0rr
parents:
diff changeset
   115
protoNumber2ver _ = "Unknown"
4e78ad846fb6 New game server:
unc0rr
parents:
diff changeset
   116
1964
dc9ea05c9d2f - Another way of defining official server
unc0rr
parents: 1953
diff changeset
   117
askFromConsole :: String -> IO String
dc9ea05c9d2f - Another way of defining official server
unc0rr
parents: 1953
diff changeset
   118
askFromConsole msg = do
2867
9be6693c78cb - Unbreak support for client versions prior to 0.9.13-dev
unc0rr
parents: 2747
diff changeset
   119
    putStr msg
9be6693c78cb - Unbreak support for client versions prior to 0.9.13-dev
unc0rr
parents: 2747
diff changeset
   120
    hFlush stdout
9be6693c78cb - Unbreak support for client versions prior to 0.9.13-dev
unc0rr
parents: 2747
diff changeset
   121
    getLine