gameServer/Utils.hs
author unc0rr
Thu, 27 Jan 2011 22:06:42 +0300
branchserver_refactor
changeset 4597 31e042ab870c
parent 4583 ab82045ea083
child 4599 a9e4093a7e78
permissions -rw-r--r--
Finally a solution for excess lazyness when working with unsafeThaw'ed arrays
Ignore whitespace changes - Everywhere: Within whitespace: At end of lines:
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
     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
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
    17
import Data.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
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
    20
import qualified Data.ByteString.Char8 as B
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
    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
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
    25
sockAddr2String :: SockAddr -> IO B.ByteString
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
    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) _) =
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
    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
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
    32
toEngineMsg :: B.ByteString -> B.ByteString
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
    33
toEngineMsg msg = B.pack $ Base64.encode (fromIntegral (BW.length msg) : (BW.unpack msg))
1804
4e78ad846fb6 New game server:
unc0rr
parents:
diff changeset
    34
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
    35
fromEngineMsg :: B.ByteString -> Maybe B.ByteString
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
    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
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
    41
checkNetCmd :: B.ByteString -> (Bool, Bool)
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
    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
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
    55
teamToNet :: TeamInfo -> [B.ByteString]
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
    56
teamToNet team =
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
    57
        "ADD_TEAM"
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
    58
        : teamname team
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
    59
        : teamgrave team
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
    60
        : teamfort team
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
    61
        : teamvoicepack team
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
    62
        : teamflag team
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
    63
        : teamowner team
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
    64
        : (B.pack $ show $ difficulty team)
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
    65
        : hhsInfo
2867
9be6693c78cb - Unbreak support for client versions prior to 0.9.13-dev
unc0rr
parents: 2747
diff changeset
    66
    where
9be6693c78cb - Unbreak support for client versions prior to 0.9.13-dev
unc0rr
parents: 2747
diff changeset
    67
        hhsInfo = concatMap (\(HedgehogInfo name hat) -> [name, hat]) $ hedgehogs team
1804
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}
2867
9be6693c78cb - Unbreak support for client versions prior to 0.9.13-dev
unc0rr
parents: 2747
diff changeset
    71
    where
9be6693c78cb - Unbreak support for client versions prior to 0.9.13-dev
unc0rr
parents: 2747
diff changeset
    72
    replaceTeam _ [] = error "modifyTeam: no such team"
9be6693c78cb - Unbreak support for client versions prior to 0.9.13-dev
unc0rr
parents: 2747
diff changeset
    73
    replaceTeam team (t:teams) =
9be6693c78cb - Unbreak support for client versions prior to 0.9.13-dev
unc0rr
parents: 2747
diff changeset
    74
        if teamname team == teamname t then
9be6693c78cb - Unbreak support for client versions prior to 0.9.13-dev
unc0rr
parents: 2747
diff changeset
    75
            team : teams
9be6693c78cb - Unbreak support for client versions prior to 0.9.13-dev
unc0rr
parents: 2747
diff changeset
    76
        else
9be6693c78cb - Unbreak support for client versions prior to 0.9.13-dev
unc0rr
parents: 2747
diff changeset
    77
            t : replaceTeam team teams
1804
4e78ad846fb6 New game server:
unc0rr
parents:
diff changeset
    78
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
    79
illegalName :: B.ByteString -> Bool
4581
af2e231bd9be Apply new nick restrictions in server rewrite too
unc0rr
parents: 4569
diff changeset
    80
illegalName b = null s || all isSpace s || isSpace (head s) || isSpace (last s)
af2e231bd9be Apply new nick restrictions in server rewrite too
unc0rr
parents: 4569
diff changeset
    81
    where
af2e231bd9be Apply new nick restrictions in server rewrite too
unc0rr
parents: 4569
diff changeset
    82
        s = B.unpack b
2150
45b695f3a7b9 Forbid room names and nicknames consisting only of space characters
unc0rr
parents: 2113
diff changeset
    83
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
    84
protoNumber2ver :: Word16 -> B.ByteString
4569
a835465b4fd2 Convert function to a map
unc0rr
parents: 4337
diff changeset
    85
protoNumber2ver v = Map.findWithDefault "Unknown" v vermap
a835465b4fd2 Convert function to a map
unc0rr
parents: 4337
diff changeset
    86
    where
a835465b4fd2 Convert function to a map
unc0rr
parents: 4337
diff changeset
    87
        vermap = Map.fromList [
a835465b4fd2 Convert function to a map
unc0rr
parents: 4337
diff changeset
    88
            (17, "0.9.7-dev"),
a835465b4fd2 Convert function to a map
unc0rr
parents: 4337
diff changeset
    89
            (19, "0.9.7"),
a835465b4fd2 Convert function to a map
unc0rr
parents: 4337
diff changeset
    90
            (20, "0.9.8-dev"),
a835465b4fd2 Convert function to a map
unc0rr
parents: 4337
diff changeset
    91
            (21, "0.9.8"),
a835465b4fd2 Convert function to a map
unc0rr
parents: 4337
diff changeset
    92
            (22, "0.9.9-dev"),
a835465b4fd2 Convert function to a map
unc0rr
parents: 4337
diff changeset
    93
            (23, "0.9.9"),
a835465b4fd2 Convert function to a map
unc0rr
parents: 4337
diff changeset
    94
            (24, "0.9.10-dev"),
a835465b4fd2 Convert function to a map
unc0rr
parents: 4337
diff changeset
    95
            (25, "0.9.10"),
a835465b4fd2 Convert function to a map
unc0rr
parents: 4337
diff changeset
    96
            (26, "0.9.11-dev"),
a835465b4fd2 Convert function to a map
unc0rr
parents: 4337
diff changeset
    97
            (27, "0.9.11"),
a835465b4fd2 Convert function to a map
unc0rr
parents: 4337
diff changeset
    98
            (28, "0.9.12-dev"),
a835465b4fd2 Convert function to a map
unc0rr
parents: 4337
diff changeset
    99
            (29, "0.9.12"),
a835465b4fd2 Convert function to a map
unc0rr
parents: 4337
diff changeset
   100
            (30, "0.9.13-dev"),
a835465b4fd2 Convert function to a map
unc0rr
parents: 4337
diff changeset
   101
            (31, "0.9.13"),
a835465b4fd2 Convert function to a map
unc0rr
parents: 4337
diff changeset
   102
            (32, "0.9.14-dev"),
a835465b4fd2 Convert function to a map
unc0rr
parents: 4337
diff changeset
   103
            (33, "0.9.14"),
a835465b4fd2 Convert function to a map
unc0rr
parents: 4337
diff changeset
   104
            (34, "0.9.15-dev"),
a835465b4fd2 Convert function to a map
unc0rr
parents: 4337
diff changeset
   105
            (35, "0.9.14.1"),
a835465b4fd2 Convert function to a map
unc0rr
parents: 4337
diff changeset
   106
            (37, "0.9.15"),
4583
ab82045ea083 Fix typo in version information
unc0rr
parents: 4581
diff changeset
   107
            (38, "0.9.16-dev")]
1804
4e78ad846fb6 New game server:
unc0rr
parents:
diff changeset
   108
1964
dc9ea05c9d2f - Another way of defining official server
unc0rr
parents: 1953
diff changeset
   109
askFromConsole :: String -> IO String
dc9ea05c9d2f - Another way of defining official server
unc0rr
parents: 1953
diff changeset
   110
askFromConsole msg = do
2867
9be6693c78cb - Unbreak support for client versions prior to 0.9.13-dev
unc0rr
parents: 2747
diff changeset
   111
    putStr msg
9be6693c78cb - Unbreak support for client versions prior to 0.9.13-dev
unc0rr
parents: 2747
diff changeset
   112
    hFlush stdout
9be6693c78cb - Unbreak support for client versions prior to 0.9.13-dev
unc0rr
parents: 2747
diff changeset
   113
    getLine
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
   114
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
   115
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
   116
unfoldrE :: (b -> Either b (a, b)) -> b -> ([a], b)
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
   117
unfoldrE f b  =
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
   118
    case f b of
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
   119
        Right (a, new_b) -> let (a', b') = unfoldrE f new_b in (a : a', b')
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
   120
        Left new_b       -> ([], new_b)
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
   121
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
   122
showB :: Show a => a -> B.ByteString
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
   123
showB = B.pack .show