module Network.Tremulous.Protocol (
module Network.Tremulous.NameInsensitive
, Delay(..)
, Team(..)
, GameServer(..)
, Player(..)
, MasterServer(..)
, PollResult(..)
, defaultDelay
, parseGameServer
, parseMasterServer
) where
import Prelude as P hiding (Maybe(..), maybe)
import Control.Applicative as A
import Control.Monad.State.Strict
import Data.Attoparsec.Char8 hiding (option)
import Data.Attoparsec (anyWord8)
import Data.ByteString.Char8 as B
import Network.Tremulous.StrictMaybe
import Data.Bits
import Data.Word
import Network.Socket
import Network.Tremulous.ByteStringUtils as B
import Network.Tremulous.SocketExtensions
import Network.Tremulous.NameInsensitive
import Network.Tremulous.TupleReader
data Delay = Delay
{ packetTimeout
, packetDuplication
, throughputDelay :: !Int
}
data MasterServer = MasterServer
{ masterAddress :: !SockAddr
, masterProtocol :: !Int
} deriving Eq
data GameServer = GameServer
{ address :: !SockAddr
, gameping
, protocol :: !Int
, hostname :: !TI
, gamemod
, version
, mapname :: !(Maybe TI)
, slots :: !Int
, privslots :: !Int
, protected
, unlagged :: !Bool
, timelimit
, suddendeath :: !(Maybe Int)
, nplayers :: !Int
, players :: ![Player]
}
data Team = Spectators | Aliens | Humans | Unknown deriving (Eq, Show)
data Player = Player
{ team :: !Team
, kills
, ping :: !Int
, name :: !TI
}
data PollResult = PollResult
{ polled :: ![GameServer]
, serversResponded
, serversRequested :: !Int
}
defaultDelay :: Delay
defaultDelay = Delay
{ packetTimeout = 400 * 1000
, packetDuplication = 2
, throughputDelay = 1 * 1000
}
parsePlayer :: Team -> ByteString -> Maybe Player
parsePlayer team = parseMaybe $ do
kills <- signed decimal
skipSpace
ping <- signed decimal
skipSpace
name <- mkColor <$> quoted
return Player {..}
parseP :: ByteString -> [Team]
parseP = foldr' f []
where
f '-' xs = xs
f a xs = readTeam a : xs
readTeam x = case x of
'0' -> Spectators
'1' -> Aliens
'2' -> Humans
_ -> Unknown
parsePlayers :: Maybe ByteString -> [ByteString] -> Maybe [Player]
parsePlayers Nothing xs = mapM (parsePlayer Unknown) xs
parsePlayers (Just p) xs = zipWithM parsePlayer (parseP p ++ repeat Unknown) xs
parseCVars :: ByteString -> [(ByteString, ByteString)]
parseCVars xs = f (splitfilter '\\' xs) where
f (k:v:cs) = (k, v) : f cs
f _ = []
parseGameServer :: SockAddr -> ByteString -> Maybe GameServer
parseGameServer address str = do
xs <- stripPrefix "\xFF\xFF\xFF\xFFstatusResponse" str
case splitlines xs of
(cvars:players) -> mkGameServer address players (parseCVars cvars)
_ -> Nothing
mkGameServer :: SockAddr
-> [ByteString]
-> [(ByteString, ByteString)]
-> Maybe GameServer
mkGameServer address rawplayers = tupleReader $ do
timelimit <- optionWith maybeInt "timelimit"
hostname <- mkColor <$> require "sv_hostname"
protocol <- requireWith maybeInt "protocol"
mapname <- optionWith (Just . mk) "mapname"
version <- optionWith (Just . mk) "version"
gamemod <- optionWith mkMod "gamename"
p <- option "P"
players <- lift $ parsePlayers p rawplayers
protected <- mkBool <$> option "g_needpass"
privslots <- fromMaybe 0 <$> optionWith maybeInt
"sv_privateClients"
slots <- subtract privslots <$> requireWith maybeInt
"sv_maxclients"
suddendeath <- optionWith maybeInt "g_suddenDeathTime"
unlagged <- mkBool <$> option "g_unlagged"
return GameServer
{ gameping = 1
, nplayers = P.length players
, ..
}
where
mkMod "base" = Nothing
mkMod a = Just (mk a)
mkBool = maybe False (/="0")
parseMasterServer :: ByteString -> Maybe [SockAddr]
parseMasterServer = parseMaybe (static *> A.many addr)
where
static = string "\xFF\xFF\xFF\xFFgetserversResponse"
addr = do
char '\\'
ip <- parseUInt32N
port <- parseUInt16N
if port == 0 || ip == 0
then addr
else return $ SockAddrInet (PortNum (htons port)) (htonl ip)
parseUInt32N :: Parser Word32
parseUInt32N = do
b3 <- wg
b2 <- wg
b1 <- wg
b0 <- wg
return $ (b3 << 24) .|. (b2 << 16) .|. (b1 << 8) .|. b0
where
wg = fromIntegral <$> anyWord8
(<<) = unsafeShiftL
parseUInt16N :: Parser Word16
parseUInt16N = do
b1 <- wg
b0 <- wg
return $ (b1 << 8) .|. b0
where
wg = fromIntegral <$> anyWord8
(<<) = unsafeShiftL
quoted :: Parser ByteString
quoted = char '"' *> takeTill (=='"') <* char '"'
parseMaybe :: Parser a -> ByteString -> Maybe a
parseMaybe f xs = case parseOnly f xs of
Right a -> Just a
Left _ -> Nothing