tremulous-query 1.0.1 → 1.0.2

raw patch · 6 files changed

+101/−42 lines, 6 filesdep +Win32dep −old-timePVP: major bump suggested

API removals or changes: PVP suggests a major version bump

Dependencies added: Win32

Dependencies removed: old-time

API changes (from Hackage documentation)

Files

• Network/Tremulous/MicroTime.hs +47/−0
• Network/Tremulous/NameInsensitive.hs +6/−6
• Network/Tremulous/Polling.hs +5/−6
• Network/Tremulous/Scheduler.hs +33/−24
• Network/Tremulous/Util.hs +5/−1
• tremulous-query.cabal +5/−5

@@ -0,0 +1,47 @@+{-# LANGUAGE CPP #-}+-- This module is based on code from the "time" package, and is licensed BSD3.+module Network.Tremulous.MicroTime (MicroTime, getMicroTime) where++#ifdef mingw32_HOST_OS+import Data.Word+import System.Win32.Time+#else+import Foreign+import Foreign.C+#endif++type MicroTime = Word64+getMicroTime :: IO MicroTime++#ifdef mingw32_HOST_OS+getMicroTime = do+	FILETIME ft <- System.Win32.Time.getSystemTimeAsFileTime+	return ((ft - win32_epoch_adjust) `div` 10)++win32_epoch_adjust :: Word64+win32_epoch_adjust = 116444736000000000++#else+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++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+#endif

@@ -36,11 +36,11 @@ mkAlphaNum bs = TI bs (B.map toLower $ B.filter isAlphaNum bs)  removeColors :: ByteString -> ByteString-removeColors = B.pack . rc . B.unpack--rc :: String -> String-rc ('^' : x : xs) | isAlphaNum x	= rc xs-rc (x : xs)				= x : rc xs-rc [] 					= []+removeColors = B.unfoldr f where+	f bs	| Just ('^', xs) <- t+		, Just (x, xs2)  <- B.uncons xs+		, isAlphaNum x		= B.uncons xs2+		| otherwise		= t+		where t = B.uncons bs  

@@ -22,6 +22,7 @@ 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@@ -45,7 +46,7 @@ 	tstate		<- newMVar S.empty 	 	-- When first packet was sent to server (removed on proper response)-	pingstate	<- newMVar (M.empty :: Map SockAddr Integer)+	pingstate	<- newMVar (M.empty :: Map SockAddr MicroTime)  	let sf sched host qtype = case qtype of 		QGame n		-> do@@ -85,7 +86,7 @@ 				let m' = S.union m x 				putMVar' mstate m' 				let delta = S.difference x m-				when (S.size delta > 0) $ do+				when (S.size delta > 0) $ 					addScheduledInstant sched $ map (,QGame packetDuplication) (S.toList delta) 				 				buildResponse@@ -107,12 +108,11 @@ 					case start of 						Nothing -> buildResponse 						Just a	-> do-							let gameping = fromInteger (now - a) `div` 1000+							let gameping = fromIntegral (now - a) `div` 1000 							( strict x{ gameping } : ) `liftM` buildResponse			 			Just Invalid -> buildResponse 			 			Nothing -> return []-			 	xs	<- buildResponse 	m	<- takeMVar mstate 	t	<- takeMVar tstate@@ -130,7 +130,6 @@ 	parseServer x = parseGameServer host =<< stripPrefix "statusResponse" x  - pollOne :: Delay -> SockAddr -> IO (Maybe GameServer) pollOne Delay{..} sockaddr = do 	s <- socket AF_INET Datagram defaultProtocol@@ -152,7 +151,7 @@ 		sClose sock 		killThread pid 		stop	<- getMicroTime-		let gameping = fromInteger (stop - start) `div` 1000+		let gameping = fromIntegral (stop - start) `div` 1000 		return $ (\x -> x {gameping}) <$>  			(parseGameServer sockaddr =<< isProper =<< poll) 	err sock (_::IOError) = sClose sock >> return Nothing

@@ -1,18 +1,16 @@ module Network.Tremulous.Scheduler( 	  Event, Scheduler 	, newScheduler, startScheduler, addScheduled, addScheduledBatch-	, addScheduledInstant, deleteScheduled, getMicroTime+	, addScheduledInstant, deleteScheduled ) where import Prelude hiding (drop) import Control.Monad-import Control.Applicative hiding (empty) import Control.Concurrent import Control.Exception import Data.Typeable import Data.Sequence import Data.Foldable-import System.Time-+import Network.Tremulous.MicroTime  data Interrupt = Interrupt 	deriving (Typeable, Show)@@ -22,10 +20,10 @@ data (Eq id, Ord id) => Scheduler id a = Scheduler 	{ sync		:: !(MVar ()) 	, started	:: !(MVar ())-	, queue		:: !(MVar (Seq (Integer, id, a)))+	, queue		:: !(MVar (Seq (Event id a))) 	} -type Event id a = (Integer, id, a)+type Event id a = (MicroTime, id, a)  -- ugly ugly ugly! threadBlock :: IO ()@@ -48,31 +46,45 @@ 	where 	runner sched@Scheduler{..} restore = do 		takeMVar started-		tid		<- myThreadId-		syncid		<- forkIOUnmasked $ forever $ takeMVar sync >> throwTo tid Interrupt+		tid <- myThreadId 		let loop = do-			q <- readMVar queue+			q <- takeMVar queue 			case viewl q of 				EmptyL -> case finalizer of 					Nothing -> do+						putMVar queue q 						ignoreException $ restore threadBlock 						loop-					Just a -> do-						killThread syncid-						a--				(time, idn, storage) :< _ -> do+					Just a -> a+					+				(0, idn, storage) :< qs -> do+					putMVar queue qs+					func sched idn storage+					when (throughput > 0)+						(threadDelay throughput)+					loop+				+				(time, idn, storage) :< qs -> do 					now <- getMicroTime-					let wait = fromInteger (time - now)-					waited <- ((time == -1 || wait <= 0) ||) `liftM`-						falseOnException (restore (threadDelay wait))-					when waited $ do-						pureModifyMVar queue $ deleteID idn+					let wait = fromIntegral (time - now)+					if wait <= 0 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+						waited <- falseOnException $ restore $ threadDelay wait+						when waited $ do+							killThread syncid+							pureModifyMVar queue $ deleteID idn+							func sched idn storage+							when (throughput > 0)+								(threadDelay throughput) 					loop-		loop+			in loop  signal :: MVar () -> IO () signal a = tryPutMVar a () >> return ()@@ -92,16 +104,13 @@  addScheduledInstant :: (Ord id, Eq id, Foldable f) => Scheduler id a -> f (id, a) -> IO () addScheduledInstant Scheduler{..} events = do-	pureModifyMVar queue $ \q -> foldl' (\acc (a, b) -> (-1, a, b) <| acc) q events+	pureModifyMVar queue $ \q -> foldl' (\acc (a, b) -> (0, a, b) <| acc) q events 	signal sync  deleteScheduled :: (Ord id, Eq id) => Scheduler id a -> id -> IO () deleteScheduled Scheduler{..} ident = do 	pureModifyMVar queue $ deleteID ident 	signal sync--getMicroTime :: IO Integer-getMicroTime = let f (TOD s p) = s*1000000 + p `div` 1000000 in f <$> getClockTime  ignoreException :: IO () -> IO () ignoreException = handle (\Interrupt -> return ())

@@ -1,5 +1,6 @@ module Network.Tremulous.Util ( 	serverByAddress+	, elemByAddress 	, search 	, makePlayerList 	, makePlayerNameList@@ -17,7 +18,10 @@   serverByAddress :: SockAddr -> [GameServer] -> Maybe GameServer-serverByAddress add =  find (\x -> add == address x)+serverByAddress add = find (\x -> add == address x)++elemByAddress :: SockAddr -> [GameServer] -> Bool+elemByAddress add = any (\x -> add == address x)  search :: String -> [GameServer] -> [(TI, GameServer)] search ""	= makePlayerNameList 

@@ -1,5 +1,5 @@ Name:			tremulous-query-Version:		1.0.1+Version:		1.0.2 Author:			Christoffer Öjeling Maintainer:		Christoffer Öjeling <christoffer@ojeling.net> License:		GPL-3@@ -29,10 +29,10 @@                         Network.Tremulous.SocketExtensions                         Network.Tremulous.ByteStringUtils                         Network.Tremulous.Scheduler+                        Network.Tremulous.MicroTime   Other-Modules:        Network.Tremulous.TupleReader -  Build-Depends:        base>=4.3 && < 5, old-time, network, deepseq, containers, bytestring, attoparsec, mtl+  Build-Depends:        base>=4.3 && < 5, network, deepseq, containers, bytestring, attoparsec, mtl+  if os(windows)+      Build-Depends:    Win32   Ghc-Options:          -Wall -fno-warn-unused-do-bind -fno-warn-orphans -funbox-strict-fields---