tremulous-query 1.0.5 → 1.0.6
raw patch · 11 files changed
+489/−444 lines, 11 filesdep ~base
Dependency ranges changed: base
Files
- Network/Tremulous/ByteStringUtils.hs +27/−20
- Network/Tremulous/MicroTime.hs +16/−16
- Network/Tremulous/NameInsensitive.hs +16/−16
- Network/Tremulous/Polling.hs +128/−108
- Network/Tremulous/Protocol.hs +137/−124
- Network/Tremulous/Scheduler.hs +81/−77
- Network/Tremulous/SocketExtensions.hs +4/−3
- Network/Tremulous/StrictMaybe.hs +19/−19
- Network/Tremulous/TupleReader.hs +17/−17
- Network/Tremulous/Util.hs +20/−27
- tremulous-query.cabal +24/−17
Network/Tremulous/ByteStringUtils.hs view
@@ -6,16 +6,17 @@ import Network.Tremulous.StrictMaybe import Data.ByteString.Internal import Foreign+import System.IO.Unsafe as U stripPrefix :: ByteString -> ByteString -> Maybe ByteString stripPrefix p xs- | p `isPrefixOf` xs = Just $ drop (length p) xs- | otherwise = Nothing+ | p `isPrefixOf` xs = Just $ drop (length p) xs+ | otherwise = Nothing maybeInt :: ByteString -> Maybe Int maybeInt x = case readInt x of- P.Nothing -> Nothing- P.Just (a, _) -> Just a+ P.Nothing -> Nothing+ P.Just (a, _) -> Just a splitlines :: ByteString -> [ByteString] splitlines = splitfilter '\n'@@ -27,21 +28,27 @@ splitfilter f = P.filter (not . null) . split f -rebuild :: Int -> (Word8 -> ByteString -> (Word8, ByteString)) -> ByteString -> ByteString+rebuild :: Int+ -> (Word8 -> ByteString -> (Word8, ByteString))+ -> ByteString+ -> ByteString rebuild i f x0- | i < 0 = empty- | otherwise = unsafePerformIO $ createAndTrim i $ \p -> go p x0 0- where- go !p !(PS x s l) !n- | l == 0 || n == i = return n- | otherwise = do- w <- withForeignPtr x (`peekByteOff` s)- let ps' = PS x (s+1) (l-1)- let (w', ps'') = f w ps'- poke p w'- go (p `plusPtr` 1) ps'' (n+1)+ | i < 0 = empty+ | otherwise = U.unsafePerformIO $ createAndTrim i $ \p -> go p x0 0+ where+ go !p !(PS x s l) !n+ | l == 0 || n == i = return n+ | otherwise = do+ w <- withForeignPtr x (`peekByteOff` s)+ let ps' = PS x (s+1) (l-1)+ let (w', ps'') = f w ps'+ poke p w'+ go (p `plusPtr` 1) ps'' (n+1) -rebuildC :: Int -> (Char -> ByteString -> (Char, ByteString)) -> ByteString -> ByteString-rebuildC i f x0 = rebuild i f' x0- where- f' w ps = let (a, b) = f (w2c w) ps in (c2w a, b)+rebuildC :: Int+ -> (Char -> ByteString -> (Char, ByteString))+ -> ByteString+ -> ByteString+rebuildC i f = rebuild i f'+ where+ f' w ps = let (a, b) = f (w2c w) ps in (c2w a, b)
Network/Tremulous/MicroTime.hs view
@@ -15,8 +15,8 @@ #ifdef mingw32_HOST_OS getMicroTime = do- FILETIME ft <- System.Win32.Time.getSystemTimeAsFileTime- return ((ft - win32_epoch_adjust) `quot` 10)+ FILETIME ft <- System.Win32.Time.getSystemTimeAsFileTime+ return ((ft - win32_epoch_adjust) `quot` 10) win32_epoch_adjust :: Word64 win32_epoch_adjust = 116444736000000000@@ -25,23 +25,23 @@ data CTimeval = MkCTimeval !CLong !CLong instance Storable CTimeval where- sizeOf _ = (sizeOf (undefined :: CLong)) * 2- alignment _ = alignment (undefined :: CLong)- peek p = do- s <- peekElemOff (castPtr p) 0- mus <- peekElemOff (castPtr p) 1- return (MkCTimeval s mus)- poke p (MkCTimeval s mus) = do- pokeElemOff (castPtr p) 0 s- pokeElemOff (castPtr p) 1 mus+ sizeOf _ = sizeOf (undefined :: CLong) * 2+ alignment _ = alignment (undefined :: CLong)+ peek p = do+ s <- peekElemOff (castPtr p) 0+ mus <- peekElemOff (castPtr p) 1+ return (MkCTimeval s mus)+ poke p (MkCTimeval s mus) = do+ pokeElemOff (castPtr p) 0 s+ pokeElemOff (castPtr p) 1 mus foreign import ccall unsafe "time.h gettimeofday" gettimeofday :: Ptr CTimeval -> Ptr () -> IO CInt -- | Get the current POSIX time from the system clock. getMicroTime = with (MkCTimeval 0 0) $ \ptval -> do- result <- gettimeofday ptval nullPtr- if (result == 0)- then f `fmap` peek ptval- else fail ("error in gettimeofday: " ++ (show result))- where f (MkCTimeval a b) = fromIntegral a * 1000000 + fromIntegral b+ result <- gettimeofday ptval nullPtr+ if result == 0+ then f `fmap` peek ptval+ else fail ("error in gettimeofday: " ++ show result)+ where f (MkCTimeval a b) = fromIntegral a * 1000000 + fromIntegral b #endif
Network/Tremulous/NameInsensitive.hs view
@@ -1,5 +1,5 @@ module Network.Tremulous.NameInsensitive (- TI(..), mk, mkColor, mkAlphaNum+ TI(..), mk, mkColor, mkAlphaNum ) where import Prelude hiding (length, map, filter) import Data.ByteString.Char8@@ -7,41 +7,41 @@ import Data.Ord import Network.Tremulous.ByteStringUtils -data TI = TI {- original :: !ByteString- , cleanedCase :: !ByteString- }+data TI = TI+ { original :: !ByteString+ , cleanedCase :: !ByteString+ } instance Eq TI where- a == b = cleanedCase a == cleanedCase b+ a == b = cleanedCase a == cleanedCase b instance Ord TI where- compare = comparing cleanedCase+ compare = comparing cleanedCase instance Show TI where- show = show . original+ show = show . original mk :: ByteString -> TI mk xs = TI bs (map toLower bs)- where bs = clean xs+ where bs = clean xs mkColor :: ByteString -> TI mkColor xs = TI bs (removeColors bs)- where bs = clean xs+ where bs = clean xs mkAlphaNum :: ByteString -> TI mkAlphaNum xs = TI bs (map toLower $ filter (\x -> isAlphaNum x || isSpace x) bs)- where bs = clean xs+ where bs = clean xs clean :: ByteString -> ByteString clean = stripw . filter (\c -> c >= '\x20' && c <= '\x7E') removeColors :: ByteString -> ByteString removeColors bss = rebuildC (length bss) f bss where- f '^' xs | Just (x2, xs2) <- uncons xs- , isAlphaNum x2- , Just (x3, xs3) <- uncons xs2- = f x3 xs3- f x xs = (toLower x, xs)+ f '^' xs | Just (x2, xs2) <- uncons xs+ , isAlphaNum x2+ , Just (x3, xs3) <- uncons xs2+ = f x3 xs3+ f x xs = (toLower x, xs)
Network/Tremulous/Polling.hs view
@@ -1,7 +1,9 @@ module Network.Tremulous.Polling (- pollMasters, pollOne+ pollMasters+ , pollOne ) where-import Prelude hiding (all, concat, mapM_, elem, sequence_, concatMap, catch, Maybe(..), maybe, foldr)+import Prelude hiding (all, concat, mapM_, elem, sequence_, concatMap+ , catch, Maybe(..), maybe, foldr) import qualified Data.Maybe as P import Control.Monad (when)@@ -13,150 +15,168 @@ import Data.Map (Map) import qualified Data.Map as M import Data.String-import Data.ByteString.Char8 (ByteString, append, pack)+import Data.ByteString.Char8 (ByteString)+import qualified Data.ByteString.Char8 as B import Network.Tremulous.StrictMaybe import Network.Socket hiding (send, sendTo, recv, recvFrom) import Network.Socket.ByteString import Network.Tremulous.Protocol-import Network.Tremulous.ByteStringUtils as B import Network.Tremulous.MicroTime import Network.Tremulous.Scheduler -data QType = QMaster !Int !Int | QGame !Int | QJustWait-data State = Pending MasterServer | Requested !MicroTime MasterServer | Responded | Broken +data QType = QMaster !Int !Int | QGame !Int | QJustWait++data State = Pending MasterServer+ | Requested !MicroTime MasterServer+ | Responded+ | Broken+ deriving Eq++ mtu :: Int mtu = 2048 getStatus :: IsString s => s getStatus = "\xFF\xFF\xFF\xFFgetstatus"+ getServers :: Int -> ByteString-getServers proto = "\xFF\xFF\xFF\xFFgetservers " `append` pack (show proto) `append` " empty full"+getServers proto = B.concat [ "\xFF\xFF\xFF\xFFgetservers "+ , B.pack (show proto)+ , " empty full" ] pollMasters :: Delay -> [MasterServer] -> IO PollResult pollMasters Delay{..} masterservers = do- sock <- socket AF_INET Datagram defaultProtocol- bindSocket sock (SockAddrInet 0 0)+ sock <- socket AF_INET Datagram defaultProtocol+ bindSocket sock (SockAddrInet 0 0) - finished <- newEmptyMVar+ finished <- newEmptyMVar+ state <- newMVar (M.empty :: Map SockAddr State) - state <- newMVar (M.empty :: Map SockAddr State)+ let finalizer = putMVar finished () >> sClose sock+ sched <- newScheduler throughputDelay+ (schedFunc sock state)+ (Just finalizer) - let sf sched host qtype = case qtype of- QGame n -> do- now <- getMicroTime- -- The first packet sent, which is why it's okey to just insert and replace- -- the current Pending value- when (n == packetDuplication) $- pureModifyMVar state $ M.update (\x -> case x of- Pending ms -> P.Just (Requested now ms)- _ -> P.Nothing)- host- sendTo sock getStatus host- addScheduled sched $ if (n > 0)- then E (now + fromIntegral packetTimeout) host (QGame (n-1))- else E (now + fromIntegral packetTimeout) host QJustWait+ addScheduledInstant sched $ map instantMaster masterservers - QMaster n proto -> do- now <- getMicroTime- sendTo sock (getServers proto) host- addScheduled sched $ if (n > 0)- then E (now + fromIntegral packetTimeout `quot` 2) host (QMaster (n-1) proto)- else E (now + fromIntegral packetTimeout) host QJustWait+ let buildResponse = do+ packet <- ioForce finished $ recvFrom sock mtu+ case packet of+ Nothing -> return []+ Just a -> do+ res <- buildOne sched state a+ case res of+ Nothing -> buildResponse+ Just b -> (b:) <$> buildResponse - QJustWait -> return ()+ xs <- buildResponse+ s <- takeMVar state - sched <- newScheduler throughputDelay sf (Just (putMVar finished () >> sClose sock))- addScheduledInstant sched $- map (\MasterServer{..} -> (masterAddress, QMaster (packetDuplication*4) masterProtocol)) masterservers+ let (nResp, nNot) = count (==Responded) s+ return (PollResult xs nResp (nResp+nNot)) - let buildResponse = do- packet <- forceIO finished $ recvFrom sock mtu- now <- getMicroTime- case parsePacket <$> packet of- -- The master responded, great! Now lets send requests to the new servers- Just (Master host xs) -> case find (\x -> host == masterAddress x) masterservers of- P.Just masterServer -> do- deleteScheduled sched host- s <- takeMVar state- let (s', delta) = foldr (masterRoll masterServer) (s, []) xs- addScheduledInstant sched $ map (,QGame packetDuplication) delta- putMVar' state s'- buildResponse+ where+ ptimeout = fromIntegral packetTimeout - P.Nothing -> buildResponse+ schedFunc sock state sched host qtype = case qtype of+ QGame n -> do+ now <- getMicroTime+ -- The first packet sent, which is why it's okey to just+ -- insert and replace the current Pending value+ when (n == packetDuplication) $+ pureModifyMVar state $ M.update (\x -> case x of+ Pending ms -> P.Just (Requested now ms)+ _ -> P.Nothing)+ host+ sendTo sock getStatus host+ addScheduled sched $ if n > 0+ then E (now + ptimeout) host (QGame (n-1))+ else E (now + ptimeout) host QJustWait - Just (Tremulous host x) -> do- s <- takeMVar state- case M.lookup host s of- P.Just (Requested start MasterServer{..}) -> do- deleteScheduled sched host- -- This one is for you, devhc- if protocol x == masterProtocol then do- let gameping = fromIntegral (now - start) `quot` 1000- putMVar' state $ M.insert host Responded s- (x{ gameping } :) <$> buildResponse- else do- putMVar' state $ M.insert host Broken s- buildResponse- _ -> do- putMVar' state s- buildResponse- Just Invalid -> buildResponse+ QMaster n proto -> do+ now <- getMicroTime+ sendTo sock (getServers proto) host+ addScheduled sched $ if n > 0+ then E (now + ptimeout `quot` 2) host (QMaster (n-1) proto)+ else E (now + ptimeout) host QJustWait - Nothing -> return []+ QJustWait -> return () - xs <- buildResponse- s <- takeMVar state- let (nResp, nNot) = ssum s- return (PollResult xs nResp (nResp+nNot))+ instantMaster MasterServer{..} =+ ( masterAddress+ , QMaster (packetDuplication*4) masterProtocol ) - where- forceIO m f = catch (Just <$> f) $ \(_ :: IOError) -> do- b <- isEmptyMVar m- if b then forceIO m f else return Nothing- masterRoll ms host ~(!m, xs) | M.member host m = (m, xs)- | otherwise = (M.insert host (Pending ms) m, host:xs)- ssum = foldl' f (0, 0) where- f (!a, !b) Responded = (a+1, b)- f (!a, !b) _ = (a, b+1) + buildOne sched state (content, host)+ | P.Just msrv <- findMaster host = do+ whenJust (parseMasterServer content) $ \xs -> do+ deleteScheduled sched host+ s <- takeMVar state+ let (s', delta) = foldr (masterRoll msrv) (s, []) xs+ addScheduledInstant sched $ map (,QGame packetDuplication) delta+ putMVar' state s'+ return Nothing+ | otherwise = do+ now <- getMicroTime+ s <- takeMVar state+ case M.lookup host s of+ P.Just (Requested start MasterServer{..})+ | Just x <- parseGameServer host content -> do+ deleteScheduled sched host+ -- This one is for you, devhc+ if protocol x == masterProtocol then do+ putMVar' state $ M.insert host Responded s+ let ping' = fromIntegral (now - start) `quot` 1000+ return $ Just x{gameping = ping'}+ else do+ putMVar' state $ M.insert host Broken s+ return Nothing+ _ -> do+ putMVar' state s+ return Nothing -data Packet = Master !SockAddr ![SockAddr] | Tremulous !SockAddr !GameServer | Invalid -parsePacket :: (ByteString, SockAddr) -> Packet-parsePacket (content, host) = case B.stripPrefix "\xFF\xFF\xFF\xFF" content of- Just a | Just x <- parseServer a -> Tremulous host x- | Just x <- parseMaster a -> Master host x- _ -> Invalid- where- parseMaster x = parseMasterServer <$> stripPrefix "getserversResponse" x- parseServer x = parseGameServer host =<< stripPrefix "statusResponse" x + findMaster host = find (\x -> host == masterAddress x) masterservers+ masterRoll ms host ~(!m, xs)+ | M.member host m = (m, xs)+ | otherwise = (M.insert host (Pending ms) m, host:xs) ++count :: (Integral i, Foldable f) => (a -> Bool) -> f a -> (i, i)+count p = foldl' go (0, 0) where+ go (!a, !b) x | p x = (a+1, b)+ | otherwise = (a, b+1)++ pollOne :: Delay -> SockAddr -> IO (Maybe GameServer)-pollOne Delay{..} sockaddr = handle err $ bracket (socket AF_INET Datagram defaultProtocol) sClose $ \sock -> do- connect sock sockaddr- pid <- forkIO $ whileJust packetDuplication $ \n -> do- send sock getStatus- threadDelay packetTimeout- if n > 0 then- return $ Just (n-1)- else do- sClose sock- return Nothing+pollOne Delay{..} sockaddr = mkS $ \sock -> do+ connect sock sockaddr+ tid <- forkIO $ whileJust packetDuplication $ \n -> do+ send sock getStatus+ threadDelay packetTimeout+ if n > 0 then+ return $ Just (n-1)+ else do+ sClose sock+ return Nothing - start <- getMicroTime- poll <- ioMaybe $ recv sock mtu <* killThread pid- stop <- getMicroTime- let gameping = fromIntegral (stop - start) `quot` 1000- return $ (\x -> x {gameping}) <$>- (parseGameServer sockaddr =<< isProper =<< poll)- where- err (_ :: IOError) = return Nothing- isProper = stripPrefix "\xFF\xFF\xFF\xFFstatusResponse"+ start <- getMicroTime+ poll <- ioMaybe $ recv sock mtu <* killThread tid+ stop <- getMicroTime+ let gameping = fromIntegral (stop - start) `quot` 1000+ return $ (\x -> x {gameping}) <$> (parseGameServer sockaddr =<< poll)+ where+ mkS = handle err . bracket (socket AF_INET Datagram defaultProtocol) sClose+ err (_ :: IOError) = return Nothing ioMaybe :: IO a -> IO (Maybe a) ioMaybe f = catch (Just <$> f) (\(_ :: IOError) -> return Nothing)++ioForce :: MVar m -> IO a -> IO (Maybe a)+ioForce m f = catch (Just <$> f) $ \(_ :: IOError) -> do+ b <- isEmptyMVar m+ if b then ioForce m f else return Nothing
Network/Tremulous/Protocol.hs view
@@ -1,7 +1,14 @@ module Network.Tremulous.Protocol (- module Network.Tremulous.NameInsensitive- , Delay(..), Team(..), GameServer(..), Player(..), MasterServer(..), PollResult(..)- , defaultDelay, parseGameServer, proto2string, string2proto, parseMasterServer+ 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@@ -11,7 +18,6 @@ import Data.Attoparsec (anyWord8) import Data.ByteString.Char8 as B import Network.Tremulous.StrictMaybe-import Data.String import Data.Bits import Data.Word import Network.Socket@@ -20,158 +26,165 @@ 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 Delay = Delay+ { packetTimeout+ , packetDuplication+ , throughputDelay :: !Int+ } -data GameServer = GameServer {- address :: !SockAddr- , gameping- , protocol :: !Int- , hostname :: !TI- , gamemod- , version- , mapname :: !(Maybe TI)- , slots :: !Int- , privslots :: !(Maybe Int)- , protected- , unlagged :: !Bool- , timelimit- , suddendeath :: !(Maybe Int)+data MasterServer = MasterServer+ { masterAddress :: !SockAddr+ , masterProtocol :: !Int+ } deriving Eq - , nplayers :: !Int- , players :: ![Player]- }+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 Player = Player+ { team :: !Team+ , kills+ , ping :: !Int+ , name :: !TI+ } -data PollResult = PollResult {- polled :: ![GameServer]- , serversResponded- , serversRequested :: !Int- }+data PollResult = PollResult+ { polled :: ![GameServer]+ , serversResponded+ , serversRequested :: !Int+ } defaultDelay :: Delay-defaultDelay = Delay {- packetTimeout = 400 * 1000- , packetDuplication = 2- , throughputDelay = 1 * 1000- }---- Protocol version-proto2string :: IsString s => Int -> s-proto2string x = case x of- 69 -> "1.1"- 70 -> "gpp"- _ -> "?"--string2proto :: (IsString s, Eq s) => s -> Maybe Int-string2proto x = case x of- "vanilla" -> Just 69- "1.1" -> Just 69- "gpp" -> Just 70- "1.2" -> Just 70- _ -> Nothing+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 {..}+ kills <- signed decimal+ skipSpace+ ping <- signed decimal+ skipSpace+ name <- mkColor <$> quoted+ return Player {..} -- cvar P parseP :: ByteString -> [Team] parseP = foldr' f []- where- f '-' xs = xs- f a xs = readTeam a : xs+ where+ f '-' xs = xs+ f a xs = readTeam a : xs - readTeam x = case x of- '0' -> Spectators- '1' -> Aliens- '2' -> Humans- _ -> Unknown+ readTeam x = case x of+ '0' -> Spectators+ '1' -> Aliens+ '2' -> Humans+ _ -> Unknown -parsePlayers :: (Maybe ByteString) -> [ByteString] -> Maybe [Player]+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 _ = []+ f (k:v:cs) = (k, v) : f cs+ f _ = [] parseGameServer :: SockAddr -> ByteString -> Maybe GameServer-parseGameServer address xs = case splitlines xs of- (cvars:players) -> mkGameServer address players (parseCVars cvars)- _ -> Nothing+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 :: 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 <- maybe False (/="0") <$> option "g_needpass"- privslots <- optionWith maybeInt "sv_privateClients"- slots <- maybe id subtract privslots <$> requireWith maybeInt "sv_maxclients"- suddendeath <- optionWith maybeInt "g_suddenDeathTime"- unlagged <- maybe False (/="0") <$> option "g_unlagged"+ 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") - return GameServer { gameping = -1, nplayers = P.length players, .. }- where- mkMod "base" = Nothing- mkMod a = Just (mk a) +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) -parseMasterServer :: ByteString -> [SockAddr]-parseMasterServer = fromMaybe [] . parseMaybe (A.many addr)- where- wg = anyWord8- f :: (Integral a, Integral b) => a -> b- f = fromIntegral- addr = do- char '\\'- i3 <- wg- i2 <- wg- i1 <- wg- i0 <- wg- p1 <- wg- p0 <- wg- let ip = (f i3 .<<. 24) .|. (f i2 .<<. 16) .|. (f i1 .<<. 8) .|. f i0 :: Word32- port = (f p1 .<<. 8) .|. f p0 :: Word16- if port == 0 || ip == 0- then addr- else return $ SockAddrInet (PortNum (htons port)) (htonl ip)-(.<<.) :: Bits a => a -> Int -> a-(.<<.) = shiftL--- /// Attoparsec utils ////////////////////////////////////////////////////////////////////////////+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+++-- /// Attoparsec utils ////////////////////////////////////////////////////////+ 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+ Right a -> Just a+ Left _ -> Nothing
Network/Tremulous/Scheduler.hs view
@@ -1,8 +1,8 @@ module Network.Tremulous.Scheduler(- Event(..), Scheduler- , newScheduler, addScheduled, addScheduledBatch- , addScheduledInstant, deleteScheduled- , putMVar', pureModifyMVar+ Event(..), Scheduler+ , newScheduler, addScheduled, addScheduledBatch+ , addScheduledInstant, deleteScheduled+ , putMVar', pureModifyMVar ) where import Prelude hiding (Maybe(..)) import Network.Tremulous.StrictMaybe@@ -14,109 +14,113 @@ import Network.Tremulous.MicroTime data Interrupt = Interrupt- deriving (Typeable, Show)+ deriving (Typeable, Show) instance Exception Interrupt -data Scheduler id a = (Eq id, Ord id) =>- Scheduler { sync :: !(MVar ())- , queue :: !(MVar [Event id a])- }+data Scheduler id a = Ord id => Scheduler+ { sync :: !(MVar ())+ , queue :: !(MVar [Event id a])+ } -data Event id a = E- { time :: !MicroTime- , idn :: !id- , storage :: !a- }+data Event id a = Ord id => E+ { time :: !MicroTime+ , idn :: !id+ , storage :: !a+ } -newScheduler :: (Eq a, Ord a) => Int -> (Scheduler a b -> a -> b -> IO ()) -> Maybe (IO ()) -> IO (Scheduler a b)+newScheduler :: Ord a => Int -> (Scheduler a b -> a -> b -> IO ())+ -> Maybe (IO ()) -> IO (Scheduler a b) newScheduler throughput func finalizer = do- queue <- newMVar []- sync <- newEmptyMVar- let sched = Scheduler{..}- uninterruptibleMask $ \a -> forkIO $ runner sched a- return sched+ queue <- newMVar []+ sync <- newEmptyMVar+ let sched = Scheduler{..} - where- runner sched@Scheduler{..} restore = do- takeMVar sync- tid <- myThreadId- let loop = do- q <- takeMVar queue- case q of- [] -> putMVar' queue q >> case finalizer of- Nothing -> do- takeMVar sync- loop- Just a -> a+ uninterruptibleMask $ \restore -> forkIO $ do+ takeMVar sync+ runner sched restore =<< myThreadId - E{time=0, ..} : qs -> do- putMVar' queue qs- func sched idn storage- when (throughput > 0)- (threadDelay throughput)- loop+ return sched+ where+ runner sched@Scheduler{..} restore tid = loop where+ loop = do+ q <- takeMVar queue+ case q of+ [] -> do+ putMVar' queue q+ fromMaybe (takeMVar sync >> loop) finalizer - E {..} : qs -> do- now <- getMicroTime- if now >= time then do- putMVar' queue qs- func sched idn storage- when (throughput > 0)- (threadDelay throughput)- else do- putMVar' queue q- tryTakeMVar sync- syncid <- forkIOUnmasked $ takeMVar sync >> throwTo tid Interrupt- let wait = fromIntegral (time - now)- waited <- falseOnInterrupt $ restore $ threadDelay wait- when waited $ do- killThread syncid- pureModifyMVar queue $ deleteID idn- func sched idn storage- when (throughput > 0)- (threadDelay throughput)- loop- in loop+ E{time=0, ..} : qs -> do+ putMVar' queue qs+ func sched idn storage+ limiter+ loop + E{..} : qs -> do+ now <- getMicroTime+ if now >= time then do+ putMVar' queue qs+ func sched idn storage+ limiter+ else do+ putMVar' queue q+ tryTakeMVar sync+ syncid <- forkIO $ restore $ do+ takeMVar sync+ throwTo tid Interrupt+ let wait = fromIntegral (time - now)+ waited <- falseOnInterrupt $ restore $ threadDelay wait+ when waited $ do+ killThread syncid+ pureModifyMVar queue $ deleteID idn+ func sched idn storage+ limiter+ loop+ limiter | throughput > 0 = threadDelay throughput+ | otherwise = return ()+++ signal :: MVar () -> IO ()-signal a = tryPutMVar a () >> return ()+signal a = void $ tryPutMVar a () addScheduled :: Scheduler id a -> Event id a -> IO () addScheduled Scheduler{..} event = do- pureModifyMVar queue $ insertTimed event- signal sync+ pureModifyMVar queue $ insertTimed event+ signal sync addScheduledBatch :: Foldable f => Scheduler id a -> f (Event id a) -> IO () addScheduledBatch Scheduler{..} events = do- pureModifyMVar queue $ \q -> foldl' (flip insertTimed) q events- signal sync+ pureModifyMVar queue $ \q -> foldl' (flip insertTimed) q events+ signal sync addScheduledInstant :: Scheduler id a -> [(id, a)] -> IO () addScheduledInstant Scheduler{..} events = do- pureModifyMVar queue $ \q -> (map (uncurry (E 0)) events) ++ q- signal sync+ pureModifyMVar queue $ \q -> map (uncurry (E 0)) events ++ q+ signal sync deleteScheduled :: Scheduler id a -> id -> IO () deleteScheduled Scheduler{..} ident = do- pureModifyMVar queue $ deleteID ident- signal sync+ pureModifyMVar queue $ deleteID ident+ signal sync falseOnInterrupt :: IO a -> IO Bool falseOnInterrupt f = handle (\Interrupt -> return False) (f >> return True) -insertTimed :: (Ord id, Eq id) => Event id a -> [Event id a] -> [Event id a]+insertTimed :: Event id a -> [Event id a] -> [Event id a]+insertTimed e [] = [e] insertTimed e (x:xs)- | time e >= time x = x : insertTimed e xs- | otherwise = e : x : xs-insertTimed e [] = [e]+ | time e >= time x = x : insertTimed e xs+ | otherwise = e : x : xs -deleteID :: (Ord id, Eq id) => id -> [Event id a] -> [Event id a]-deleteID match xss = case xss of- x:xs | idn x == match -> xs- | otherwise -> x : deleteID match xs- [] -> []++deleteID :: Ord id => id -> [Event id a] -> [Event id a]+deleteID _ [] = []+deleteID match (x:xs)+ | idn x == match = xs+ | otherwise = x : deleteID match xs+ putMVar' :: MVar a -> a -> IO () putMVar' m !a = putMVar m a
Network/Tremulous/SocketExtensions.hs view
@@ -8,10 +8,11 @@ deriving instance Ord SockAddr instance NFData SockAddr where- rnf (SockAddrInet (PortNum a) b) = rnf a `seq` rnf b- rnf (SockAddrInet6 (PortNum a) b c d) = rnf a `seq` rnf b `seq` rnf c `seq` rnf d+ rnf (SockAddrInet (PortNum a) b) = rnf a `seq` rnf b+ rnf (SockAddrInet6 (PortNum a) b c d) = rnf a `seq` rnf b+ `seq` rnf c `seq` rnf d #if !defined(mingw32_HOST_OS) && !defined(__MINGW32__)- rnf (SockAddrUnix a) = rnf a+ rnf (SockAddrUnix a) = rnf a #endif #if defined(mingw32_HOST_OS) || defined(__MINGW32__)
Network/Tremulous/StrictMaybe.hs view
@@ -5,39 +5,39 @@ import Prelude hiding(Maybe(..), maybe) data Maybe a = Nothing | Just !a- deriving (Eq, Ord, Show, Read)+ deriving (Eq, Ord, Show, Read) instance Functor Maybe where- fmap _ Nothing = Nothing- fmap f (Just x) = Just (f x)+ fmap _ Nothing = Nothing+ fmap f (Just x) = Just (f x) instance Monad Maybe where- Nothing >>= _ = Nothing- Just a >>= f = f a- return = Just- fail _ = Nothing+ Nothing >>= _ = Nothing+ Just a >>= f = f a+ return = Just+ fail _ = Nothing isJust :: Maybe a -> Bool-isJust Nothing = False-isJust _ = True+isJust Nothing = False+isJust _ = True isNothing :: Maybe a -> Bool-isNothing Nothing = True-isNothing _ = False+isNothing Nothing = True+isNothing _ = False fromMaybe :: a -> Maybe a -> a-fromMaybe x Nothing = x-fromMaybe _ (Just y) = y+fromMaybe x Nothing = x+fromMaybe _ (Just y) = y maybe :: b -> (a -> b) -> Maybe a -> b-maybe x _ Nothing = x-maybe _ f (Just y) = f y+maybe x _ Nothing = x+maybe _ f (Just y) = f y whenJust :: Monad m => Maybe t -> (t -> m ())-> m ()-whenJust (Just a) f = f a-whenJust Nothing _ = return ()+whenJust (Just a) f = f a+whenJust Nothing _ = return () whileJust :: Monad m => a -> (a -> m (Maybe a)) -> m () whileJust x f = f x >>= \c -> case c of- Just a -> whileJust a f- Nothing -> return ()+ Just a -> whileJust a f+ Nothing -> return ()
Network/Tremulous/TupleReader.hs view
@@ -1,7 +1,7 @@ module Network.Tremulous.TupleReader where import Control.Monad.State.Strict import Network.Tremulous.StrictMaybe-import Prelude (Eq(..), otherwise, ($))+import Prelude (Eq(..), otherwise, ($), (.), id) type TupleReader k v a = StateT [(k, v)] Maybe a @@ -10,28 +10,28 @@ lookupDelete :: (Eq k) => k -> [(k, v)] -> (Maybe v, [(k, v)]) lookupDelete key = roll where- roll [] = (Nothing, [])- roll (x@(a, b):xs)- | key == a = (Just b, xs)- | otherwise = let ~(may, xs') = roll xs in (may, x:xs')+ roll [] = (Nothing, [])+ roll (x@(a, b):xs)+ | key == a = (Just b, xs)+ | otherwise = let ~(may, xs') = roll xs in (may, x:xs') require :: Eq k => k -> TupleReader k v v-require key = with key >>= lift+require key = option key >>= lift requireWith :: Eq k => (v -> Maybe a) -> k -> TupleReader k v a requireWith f key = do- e <- with key- lift $ f =<< e+ e <- option key+ lift $ f =<< e optionWith :: Eq k => (v -> Maybe a) -> k -> TupleReader k v (Maybe a) optionWith f key = do- e <- with key- return (f =<< e)+ e <- option key+ return (f =<< e) -with, option :: Eq k => k -> TupleReader k v (Maybe v)-option = with-with key = do- s <- get- let (e, s') = lookupDelete key s- put s'- return e++option :: Eq k => k -> TupleReader k v (Maybe v)+option key = do+ s <- get+ let (e, s') = lookupDelete key s+ put s'+ return e
Network/Tremulous/Util.hs view
@@ -1,14 +1,5 @@-module Network.Tremulous.Util (- serverByAddress- , elemByAddress- , search- , makePlayerList- , makePlayerNameList- , stats- , partitionTeams- , removeColors-) where-import Data.List hiding (foldl')+module Network.Tremulous.Util where+import Data.List (find) import Data.Foldable (foldl') import Data.Char import qualified Data.ByteString.Char8 as B@@ -24,10 +15,11 @@ elemByAddress add = any (\x -> add == address x) search :: String -> [GameServer] -> [(TI, GameServer)]-search "" = makePlayerNameList-search rawstr = filter (\(a, _) -> str `B.isInfixOf` cleanedCase a ) . makePlayerNameList- where- str = B.pack $ map toLower rawstr+search "" = makePlayerNameList+search rawstr = filter p . makePlayerNameList+ where+ str = B.pack $ map toLower rawstr+ p (a, _) = str `B.isInfixOf` cleanedCase a makePlayerNameList :: [GameServer] -> [(TI, GameServer)] makePlayerNameList = concatMap $ \x -> map (\a -> (name a, x)) (players x)@@ -37,20 +29,21 @@ stats :: [GameServer] -> (Int, Int, Int) stats polled = (tot, players, bots) where- tot = length polled- (players, bots) = foldl' trv (0, 0) (playerList polled)- trv (!p, !b) x = if ping x == 0 then (p, b+1) else (p+1, b)- playerList = foldr ((++) . T.players) []+ tot = length polled+ (players, bots) = foldl' trv (0, 0) (playerList polled)+ trv (!p, !b) x | ping x == 0 = (p, b+1)+ | otherwise = (p+1, b)+ playerList = foldr ((++) . T.players) [] partitionTeams :: [Player] -> ([Player], [Player], [Player], [Player]) partitionTeams = foldr f ([], [], [], []) where- f x ~(s, a, h, u) = case team x of- Spectators -> (x:s, a, h, u)- Aliens -> (s, x:a, h, u)- Humans -> (s, a, x:h, u)- Unknown -> (s, a, h, x:u)+ f x ~(s, a, h, u) = case team x of+ Spectators -> (x:s, a, h, u)+ Aliens -> (s, x:a, h, u)+ Humans -> (s, a, x:h, u)+ Unknown -> (s, a, h, x:u) removeColors :: String -> String-removeColors ('^' : x : xs) | isAlphaNum x = removeColors xs-removeColors (x : xs) = x : removeColors xs-removeColors [] = []+removeColors ('^' : x : xs) | isAlphaNum x = removeColors xs+removeColors (x : xs) = x : removeColors xs+removeColors [] = []
tremulous-query.cabal view
@@ -1,17 +1,18 @@-Name: tremulous-query-Version: 1.0.5-Author: Christoffer Öjeling-Maintainer: Christoffer Öjeling <christoffer@ojeling.net>-License: GPL-3-License-File: LICENSE-Category: Network-Synopsis: Library for polling Tremulous servers-Description: A library for polling servers from the game Tremulous.- Supports both the released 1.1 version and the 1.2 Gameplay Preview commonly known as GPP.+Name: tremulous-query+Version: 1.0.6+Author: Christoffer Öjeling+Maintainer: Christoffer Öjeling <christoffer@ojeling.net>+License: GPL-3+License-File: LICENSE+Category: Network+Synopsis: Library for polling Tremulous servers+Description: A library for polling servers from the game Tremulous.+ Supports both the released 1.1 version and the+ 1.2 Gameplay Preview commonly known as GPP. -Cabal-Version: >= 1.10-Build-Type: Simple-Tested-With: GHC==7.0.3+Cabal-Version: >= 1.10+Build-Type: Simple+Tested-With: GHC==7.6.1 Source-Repository head Type: git@@ -19,9 +20,13 @@ Library Default-Language: Haskell2010- Default-Extensions: BangPatterns TupleSections NamedFieldPuns RecordWildCards GADTs- ScopedTypeVariables OverloadedStrings DeriveDataTypeable++ Default-Extensions: BangPatterns TupleSections NamedFieldPuns+ RecordWildCards GADTs ScopedTypeVariables+ OverloadedStrings DeriveDataTypeable+ Other-Extensions: CPP StandaloneDeriving+ Exposed-Modules: Network.Tremulous.Protocol Network.Tremulous.Polling Network.Tremulous.Util@@ -33,7 +38,9 @@ Network.Tremulous.StrictMaybe Network.Tremulous.TupleReader - Build-Depends: base>=4.3 && < 5, network, containers, bytestring, attoparsec>=0.9, mtl, deepseq+ Build-Depends: base>=4.5 && < 5, network, containers,+ bytestring, attoparsec>=0.9, mtl, deepseq if os(windows) Build-Depends: Win32- Ghc-Options: -Wall -fno-warn-unused-do-bind -fno-warn-orphans -funbox-strict-fields+ Ghc-Options: -Wall -fno-warn-unused-do-bind -fno-warn-orphans+ -funbox-strict-fields