gameServer/Utils.hs
author unc0rr
Sun, 06 Jun 2010 15:29:33 +0000
changeset 3500 af8390d807d6
parent 3297 0c59b991007e
child 3501 a3159a410e5c
permissions -rw-r--r--
Use sockets instead of handles, use bytestrings instead of strings
Ignore whitespace changes - Everywhere: Within whitespace: At end of lines:
3500
af8390d807d6 Use sockets instead of handles, use bytestrings instead of strings
unc0rr
parents: 3297
diff changeset
     1
{-# LANGUAGE OverloadedStrings #-}
1804
4e78ad846fb6 New game server:
unc0rr
parents:
diff changeset
     2
module Utils where
4e78ad846fb6 New game server:
unc0rr
parents:
diff changeset
     3
4e78ad846fb6 New game server:
unc0rr
parents:
diff changeset
     4
import Control.Concurrent
4e78ad846fb6 New game server:
unc0rr
parents:
diff changeset
     5
import Control.Concurrent.STM
4e78ad846fb6 New game server:
unc0rr
parents:
diff changeset
     6
import Data.Char
4e78ad846fb6 New game server:
unc0rr
parents:
diff changeset
     7
import Data.Word
4e78ad846fb6 New game server:
unc0rr
parents:
diff changeset
     8
import qualified Data.Map as Map
4e78ad846fb6 New game server:
unc0rr
parents:
diff changeset
     9
import qualified Data.IntMap as IntMap
2304
a6e733ad0366 Implement filtering in server
unc0rr
parents: 2150
diff changeset
    10
import qualified Data.Set as Set
2310
581e59f123a2 Fix filtering
unc0rr
parents: 2309
diff changeset
    11
import Data.ByteString.Internal (w2c)
1917
c94045b70142 - Better ip2string implementation
unc0rr
parents: 1804
diff changeset
    12
import Numeric
c94045b70142 - Better ip2string implementation
unc0rr
parents: 1804
diff changeset
    13
import Network.Socket
1964
dc9ea05c9d2f - Another way of defining official server
unc0rr
parents: 1953
diff changeset
    14
import System.IO
1917
c94045b70142 - Better ip2string implementation
unc0rr
parents: 1804
diff changeset
    15
import qualified Data.List as List
2349
ba7a0813c532 Some fixes suggested by hlint
unc0rr
parents: 2310
diff changeset
    16
import Control.Monad
2304
a6e733ad0366 Implement filtering in server
unc0rr
parents: 2150
diff changeset
    17
import Maybe
1804
4e78ad846fb6 New game server:
unc0rr
parents:
diff changeset
    18
-------------------------------------------------
4e78ad846fb6 New game server:
unc0rr
parents:
diff changeset
    19
import qualified Codec.Binary.Base64 as Base64
3500
af8390d807d6 Use sockets instead of handles, use bytestrings instead of strings
unc0rr
parents: 3297
diff changeset
    20
import qualified Data.ByteString.Char8 as B
af8390d807d6 Use sockets instead of handles, use bytestrings instead of strings
unc0rr
parents: 3297
diff changeset
    21
import qualified Data.ByteString as BW
1804
4e78ad846fb6 New game server:
unc0rr
parents:
diff changeset
    22
import CoreTypes
4e78ad846fb6 New game server:
unc0rr
parents:
diff changeset
    23
1917
c94045b70142 - Better ip2string implementation
unc0rr
parents: 1804
diff changeset
    24
3500
af8390d807d6 Use sockets instead of handles, use bytestrings instead of strings
unc0rr
parents: 3297
diff changeset
    25
sockAddr2String :: SockAddr -> IO B.ByteString
af8390d807d6 Use sockets instead of handles, use bytestrings instead of strings
unc0rr
parents: 3297
diff changeset
    26
sockAddr2String (SockAddrInet _ hostAddr) = liftM B.pack $ inet_ntoa hostAddr
1917
c94045b70142 - Better ip2string implementation
unc0rr
parents: 1804
diff changeset
    27
sockAddr2String (SockAddrInet6 _ _ (a, b, c, d) _) =
3500
af8390d807d6 Use sockets instead of handles, use bytestrings instead of strings
unc0rr
parents: 3297
diff changeset
    28
    return $ B.pack $ (foldr1 (.)
2867
9be6693c78cb - Unbreak support for client versions prior to 0.9.13-dev
unc0rr
parents: 2747
diff changeset
    29
        $ List.intersperse (\a -> ':':a)
9be6693c78cb - Unbreak support for client versions prior to 0.9.13-dev
unc0rr
parents: 2747
diff changeset
    30
        $ 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
    31
3500
af8390d807d6 Use sockets instead of handles, use bytestrings instead of strings
unc0rr
parents: 3297
diff changeset
    32
toEngineMsg :: B.ByteString -> B.ByteString
af8390d807d6 Use sockets instead of handles, use bytestrings instead of strings
unc0rr
parents: 3297
diff changeset
    33
toEngineMsg msg = B.pack $ Base64.encode (fromIntegral (BW.length msg) : (BW.unpack msg))
1804
4e78ad846fb6 New game server:
unc0rr
parents:
diff changeset
    34
3500
af8390d807d6 Use sockets instead of handles, use bytestrings instead of strings
unc0rr
parents: 3297
diff changeset
    35
fromEngineMsg :: B.ByteString -> Maybe B.ByteString
af8390d807d6 Use sockets instead of handles, use bytestrings instead of strings
unc0rr
parents: 3297
diff changeset
    36
fromEngineMsg msg = Base64.decode (B.unpack msg) >>= removeLength >>= return . BW.pack
2867
9be6693c78cb - Unbreak support for client versions prior to 0.9.13-dev
unc0rr
parents: 2747
diff changeset
    37
    where
9be6693c78cb - Unbreak support for client versions prior to 0.9.13-dev
unc0rr
parents: 2747
diff changeset
    38
        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
    39
        removeLength _ = Nothing
2304
a6e733ad0366 Implement filtering in server
unc0rr
parents: 2150
diff changeset
    40
3500
af8390d807d6 Use sockets instead of handles, use bytestrings instead of strings
unc0rr
parents: 3297
diff changeset
    41
checkNetCmd :: B.ByteString -> (Bool, Bool)
af8390d807d6 Use sockets instead of handles, use bytestrings instead of strings
unc0rr
parents: 3297
diff changeset
    42
checkNetCmd = check . liftM B.unpack . fromEngineMsg
2867
9be6693c78cb - Unbreak support for client versions prior to 0.9.13-dev
unc0rr
parents: 2747
diff changeset
    43
    where
9be6693c78cb - Unbreak support for client versions prior to 0.9.13-dev
unc0rr
parents: 2747
diff changeset
    44
        check Nothing = (False, False)
9be6693c78cb - Unbreak support for client versions prior to 0.9.13-dev
unc0rr
parents: 2747
diff changeset
    45
        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
    46
        check _ = (False, False)
9be6693c78cb - Unbreak support for client versions prior to 0.9.13-dev
unc0rr
parents: 2747
diff changeset
    47
        legalMessages = Set.fromList $ "M#+LlRrUuDdZzAaSjJ,sFNpPwtghb12345" ++ slotMessages
9be6693c78cb - Unbreak support for client versions prior to 0.9.13-dev
unc0rr
parents: 2747
diff changeset
    48
        slotMessages = "\128\129\130\131\132\133\134\135\136\137\138"
1804
4e78ad846fb6 New game server:
unc0rr
parents:
diff changeset
    49
4e78ad846fb6 New game server:
unc0rr
parents:
diff changeset
    50
maybeRead :: Read a => String -> Maybe a
4e78ad846fb6 New game server:
unc0rr
parents:
diff changeset
    51
maybeRead s = case reads s of
2867
9be6693c78cb - Unbreak support for client versions prior to 0.9.13-dev
unc0rr
parents: 2747
diff changeset
    52
    [(x, rest)] | all isSpace rest -> Just x
9be6693c78cb - Unbreak support for client versions prior to 0.9.13-dev
unc0rr
parents: 2747
diff changeset
    53
    _         -> Nothing
1804
4e78ad846fb6 New game server:
unc0rr
parents:
diff changeset
    54
3500
af8390d807d6 Use sockets instead of handles, use bytestrings instead of strings
unc0rr
parents: 3297
diff changeset
    55
teamToNet :: Word16 -> TeamInfo -> [B.ByteString]
2867
9be6693c78cb - Unbreak support for client versions prior to 0.9.13-dev
unc0rr
parents: 2747
diff changeset
    56
teamToNet protocol team 
3500
af8390d807d6 Use sockets instead of handles, use bytestrings instead of strings
unc0rr
parents: 3297
diff changeset
    57
    | protocol < 30 =
af8390d807d6 Use sockets instead of handles, use bytestrings instead of strings
unc0rr
parents: 3297
diff changeset
    58
        "ADD_TEAM"
af8390d807d6 Use sockets instead of handles, use bytestrings instead of strings
unc0rr
parents: 3297
diff changeset
    59
        : teamname team
af8390d807d6 Use sockets instead of handles, use bytestrings instead of strings
unc0rr
parents: 3297
diff changeset
    60
        : teamgrave team
af8390d807d6 Use sockets instead of handles, use bytestrings instead of strings
unc0rr
parents: 3297
diff changeset
    61
        : teamfort team
af8390d807d6 Use sockets instead of handles, use bytestrings instead of strings
unc0rr
parents: 3297
diff changeset
    62
        : teamvoicepack team
af8390d807d6 Use sockets instead of handles, use bytestrings instead of strings
unc0rr
parents: 3297
diff changeset
    63
        : teamowner team
af8390d807d6 Use sockets instead of handles, use bytestrings instead of strings
unc0rr
parents: 3297
diff changeset
    64
        : (B.pack $ show $ difficulty team)
af8390d807d6 Use sockets instead of handles, use bytestrings instead of strings
unc0rr
parents: 3297
diff changeset
    65
        : hhsInfo
af8390d807d6 Use sockets instead of handles, use bytestrings instead of strings
unc0rr
parents: 3297
diff changeset
    66
    | otherwise = 
af8390d807d6 Use sockets instead of handles, use bytestrings instead of strings
unc0rr
parents: 3297
diff changeset
    67
        "ADD_TEAM"
af8390d807d6 Use sockets instead of handles, use bytestrings instead of strings
unc0rr
parents: 3297
diff changeset
    68
        : teamname team
af8390d807d6 Use sockets instead of handles, use bytestrings instead of strings
unc0rr
parents: 3297
diff changeset
    69
        : teamgrave team
af8390d807d6 Use sockets instead of handles, use bytestrings instead of strings
unc0rr
parents: 3297
diff changeset
    70
        : teamfort team
af8390d807d6 Use sockets instead of handles, use bytestrings instead of strings
unc0rr
parents: 3297
diff changeset
    71
        : teamvoicepack team
af8390d807d6 Use sockets instead of handles, use bytestrings instead of strings
unc0rr
parents: 3297
diff changeset
    72
        : teamflag team
af8390d807d6 Use sockets instead of handles, use bytestrings instead of strings
unc0rr
parents: 3297
diff changeset
    73
        : teamowner team
af8390d807d6 Use sockets instead of handles, use bytestrings instead of strings
unc0rr
parents: 3297
diff changeset
    74
        : (B.pack $ show $ difficulty team)
af8390d807d6 Use sockets instead of handles, use bytestrings instead of strings
unc0rr
parents: 3297
diff changeset
    75
        : hhsInfo
2867
9be6693c78cb - Unbreak support for client versions prior to 0.9.13-dev
unc0rr
parents: 2747
diff changeset
    76
    where
9be6693c78cb - Unbreak support for client versions prior to 0.9.13-dev
unc0rr
parents: 2747
diff changeset
    77
        hhsInfo = concatMap (\(HedgehogInfo name hat) -> [name, hat]) $ hedgehogs team
1804
4e78ad846fb6 New game server:
unc0rr
parents:
diff changeset
    78
4e78ad846fb6 New game server:
unc0rr
parents:
diff changeset
    79
modifyTeam :: TeamInfo -> RoomInfo -> RoomInfo
4e78ad846fb6 New game server:
unc0rr
parents:
diff changeset
    80
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
    81
    where
9be6693c78cb - Unbreak support for client versions prior to 0.9.13-dev
unc0rr
parents: 2747
diff changeset
    82
    replaceTeam _ [] = error "modifyTeam: no such team"
9be6693c78cb - Unbreak support for client versions prior to 0.9.13-dev
unc0rr
parents: 2747
diff changeset
    83
    replaceTeam team (t:teams) =
9be6693c78cb - Unbreak support for client versions prior to 0.9.13-dev
unc0rr
parents: 2747
diff changeset
    84
        if teamname team == teamname t then
9be6693c78cb - Unbreak support for client versions prior to 0.9.13-dev
unc0rr
parents: 2747
diff changeset
    85
            team : teams
9be6693c78cb - Unbreak support for client versions prior to 0.9.13-dev
unc0rr
parents: 2747
diff changeset
    86
        else
9be6693c78cb - Unbreak support for client versions prior to 0.9.13-dev
unc0rr
parents: 2747
diff changeset
    87
            t : replaceTeam team teams
1804
4e78ad846fb6 New game server:
unc0rr
parents:
diff changeset
    88
3500
af8390d807d6 Use sockets instead of handles, use bytestrings instead of strings
unc0rr
parents: 3297
diff changeset
    89
illegalName :: B.ByteString -> Bool
af8390d807d6 Use sockets instead of handles, use bytestrings instead of strings
unc0rr
parents: 3297
diff changeset
    90
illegalName = all isSpace . B.unpack
2150
45b695f3a7b9 Forbid room names and nicknames consisting only of space characters
unc0rr
parents: 2113
diff changeset
    91
3500
af8390d807d6 Use sockets instead of handles, use bytestrings instead of strings
unc0rr
parents: 3297
diff changeset
    92
protoNumber2ver :: Word16 -> B.ByteString
1804
4e78ad846fb6 New game server:
unc0rr
parents:
diff changeset
    93
protoNumber2ver 17 = "0.9.7-dev"
4e78ad846fb6 New game server:
unc0rr
parents:
diff changeset
    94
protoNumber2ver 19 = "0.9.7"
4e78ad846fb6 New game server:
unc0rr
parents:
diff changeset
    95
protoNumber2ver 20 = "0.9.8-dev"
4e78ad846fb6 New game server:
unc0rr
parents:
diff changeset
    96
protoNumber2ver 21 = "0.9.8"
4e78ad846fb6 New game server:
unc0rr
parents:
diff changeset
    97
protoNumber2ver 22 = "0.9.9-dev"
4e78ad846fb6 New game server:
unc0rr
parents:
diff changeset
    98
protoNumber2ver 23 = "0.9.9"
4e78ad846fb6 New game server:
unc0rr
parents:
diff changeset
    99
protoNumber2ver 24 = "0.9.10-dev"
4e78ad846fb6 New game server:
unc0rr
parents:
diff changeset
   100
protoNumber2ver 25 = "0.9.10"
1953
fd9c8e3c734d Add a special message for old hedgewars versions
unc0rr
parents: 1917
diff changeset
   101
protoNumber2ver 26 = "0.9.11-dev"
2113
89d0fa6734af Update server protocol number to version mapping
unc0rr
parents: 1964
diff changeset
   102
protoNumber2ver 27 = "0.9.11"
89d0fa6734af Update server protocol number to version mapping
unc0rr
parents: 1964
diff changeset
   103
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
   104
protoNumber2ver 29 = "0.9.12"
30b4a7c8e9b2 Teach server to know 0.9.12 and 0.9.13-dev
unc0rr
parents: 2403
diff changeset
   105
protoNumber2ver 30 = "0.9.13-dev"
3297
0c59b991007e 31 is 0.9.13
unc0rr
parents: 2952
diff changeset
   106
protoNumber2ver 31 = "0.9.13"
0c59b991007e 31 is 0.9.13
unc0rr
parents: 2952
diff changeset
   107
protoNumber2ver 32 = "0.9.14-dev"
1804
4e78ad846fb6 New game server:
unc0rr
parents:
diff changeset
   108
protoNumber2ver _ = "Unknown"
4e78ad846fb6 New game server:
unc0rr
parents:
diff changeset
   109
1964
dc9ea05c9d2f - Another way of defining official server
unc0rr
parents: 1953
diff changeset
   110
askFromConsole :: String -> IO String
dc9ea05c9d2f - Another way of defining official server
unc0rr
parents: 1953
diff changeset
   111
askFromConsole msg = do
2867
9be6693c78cb - Unbreak support for client versions prior to 0.9.13-dev
unc0rr
parents: 2747
diff changeset
   112
    putStr msg
9be6693c78cb - Unbreak support for client versions prior to 0.9.13-dev
unc0rr
parents: 2747
diff changeset
   113
    hFlush stdout
9be6693c78cb - Unbreak support for client versions prior to 0.9.13-dev
unc0rr
parents: 2747
diff changeset
   114
    getLine
3500
af8390d807d6 Use sockets instead of handles, use bytestrings instead of strings
unc0rr
parents: 3297
diff changeset
   115
af8390d807d6 Use sockets instead of handles, use bytestrings instead of strings
unc0rr
parents: 3297
diff changeset
   116
af8390d807d6 Use sockets instead of handles, use bytestrings instead of strings
unc0rr
parents: 3297
diff changeset
   117
unfoldrE :: (b -> Either b (a, b)) -> b -> ([a], b)
af8390d807d6 Use sockets instead of handles, use bytestrings instead of strings
unc0rr
parents: 3297
diff changeset
   118
unfoldrE f b  =
af8390d807d6 Use sockets instead of handles, use bytestrings instead of strings
unc0rr
parents: 3297
diff changeset
   119
    case f b of
af8390d807d6 Use sockets instead of handles, use bytestrings instead of strings
unc0rr
parents: 3297
diff changeset
   120
        Right (a, new_b) -> let (a', b') = unfoldrE f new_b in (a : a', b')
af8390d807d6 Use sockets instead of handles, use bytestrings instead of strings
unc0rr
parents: 3297
diff changeset
   121
        Left new_b       -> ([], new_b)