tremulous-query 1.0.2 → 1.0.3

raw patch · 5 files changed

+96/−109 lines, 5 filesPVP: major bump suggested

API removals or changes: PVP suggests a major version bump

API changes (from Hackage documentation)

Files

• Network/Tremulous/Polling.hs +46/−51
• Network/Tremulous/Scheduler.hs +35/−46
• Network/Tremulous/TupleReader.hs +13/−10
• Network/Tremulous/Util.hs +1/−1
• tremulous-query.cabal +1/−1

@@ -5,8 +5,7 @@  import Control.DeepSeq import Control.Monad hiding (mapM_, sequence_)-import Control.Concurrent (forkIO, threadDelay, killThread)-import Control.Concurrent.MVar+import Control.Concurrent import Control.Applicative import Control.Exception @@ -25,7 +24,7 @@ import Network.Tremulous.MicroTime import Network.Tremulous.Scheduler -data QType = QMaster !Int !Int | QGame !Int | QJustWait+data QType = QMaster !Int !Int | QGame !Int | QJustWait deriving Show  mtu :: Int mtu = 2048@@ -40,6 +39,8 @@ 	sock		<- socket AF_INET Datagram defaultProtocol 	bindSocket sock (SockAddrInet 0 0) 	+	finished	<- newEmptyMVar+	 	-- server addresses recieved by master 	mstate		<- newMVar S.empty 	-- Servers that has responded@@ -49,42 +50,38 @@ 	pingstate	<- newMVar (M.empty :: Map SockAddr MicroTime)  	let sf sched host qtype = case qtype of-		QGame n		-> do+		QGame n -> do 			now <- getMicroTime-			pureModifyMVar pingstate $ M.insertWith' (\_ b -> b) host now+			when (n == packetDuplication) $+				pureModifyMVar pingstate $ M.insert host now 			sendTo sock getStatus host-			if (n > 0) then-				addScheduled sched (now + fromIntegral packetTimeout, host, QGame (n-1))-			else-				addScheduled sched (now + fromIntegral packetTimeout, host, QJustWait)+			if (n > 0) then do+				addScheduled sched $ E (now + fromIntegral packetTimeout) host (QGame (n-1))+			else do+				addScheduled sched $ E (now + fromIntegral packetTimeout) host QJustWait 			 		QMaster n proto	-> do 			now <- getMicroTime 			sendTo sock (getServers proto) host-			if (n > 0) then-				addScheduled sched (now + (fromIntegral packetTimeout) `div` 2 , host, QMaster (n-1) proto)-			else-				addScheduled sched (now + fromIntegral packetTimeout, host, QJustWait)+			if (n > 0) then do+				addScheduled sched $ E (now + fromIntegral packetTimeout `div` 2) host (QMaster (n-1) proto)+			else do+				addScheduled sched $ E (now + fromIntegral packetTimeout) host QJustWait 				- 		QJustWait -> return () 		--	sched		<- newScheduler throughputDelay sf (Just (sClose sock))+	sched		<- newScheduler throughputDelay sf (Just (putMVar finished () >> sClose sock)) 	addScheduledInstant sched $ 		map (\MasterServer{..} -> (masterAddress, QMaster (packetDuplication*4) masterProtocol)) masterservers -	startScheduler sched-	 	let buildResponse = do-		packet <- ioMaybe $ recvFrom sock mtu-		case parsePacket (masterAddress <$> masterservers) <$> packet of+		packet <- forceIO finished $ recvFrom sock mtu+		case parsePacket (map masterAddress masterservers) <$> packet of 			-- The master responded, great! Now lets send requests to the new servers 			Just (Master host x) -> do 				deleteScheduled sched host 				m <- takeMVar mstate-				let m' = S.union m x-				putMVar' mstate m'+				putMVar' mstate (S.union m x) 				let delta = S.difference x m 				when (S.size delta > 0) $ 					addScheduledInstant sched $ map (,QGame packetDuplication) (S.toList delta)@@ -113,10 +110,15 @@ 			Just Invalid -> buildResponse 			 			Nothing -> return []+ 	xs	<- buildResponse 	m	<- takeMVar mstate 	t	<- takeMVar tstate 	return $! PollResult xs (S.size t) (S.size m) t+		+	where forceIO m f = catch (Just <$> f) $ \(_ :: IOError) -> do+		b <- isEmptyMVar m +		if b then forceIO m f else return Nothing  data Packet = Master !SockAddr !(Set SockAddr) | Tremulous !SockAddr !GameServer | Invalid @@ -131,42 +133,35 @@   pollOne :: Delay -> SockAddr -> IO (Maybe GameServer)-pollOne Delay{..} sockaddr = do-	s <- socket AF_INET Datagram defaultProtocol-	catch (f s) (err s)+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+		+	start	<- getMicroTime+	poll	<- ioMaybe $ recv sock mtu <* killThread pid+	stop	<- getMicroTime+	let gameping = fromIntegral (stop - start) `div` 1000+	return $ (\x -> x {gameping}) <$> +		(parseGameServer sockaddr =<< isProper =<< poll) 	where-	f 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-			-		start	<- getMicroTime-		poll	<- ioMaybe $ recv sock mtu-		sClose sock-		killThread pid-		stop	<- getMicroTime-		let gameping = fromIntegral (stop - start) `div` 1000-		return $ (\x -> x {gameping}) <$> -			(parseGameServer sockaddr =<< isProper =<< poll)-	err sock (_::IOError) = sClose sock >> return Nothing+	err (_ :: IOError) = return Nothing 	isProper = stripPrefix "\xFF\xFF\xFF\xFFstatusResponse"  ioMaybe :: IO a -> IO (Maybe a) ioMaybe f = catch (Just <$> f) (\(_ :: IOError) -> return Nothing) -putMVar' :: NFData a => MVar a -> a -> IO ()-putMVar' m a = rnf a `seq` putMVar m a+putMVar' :: MVar a -> a -> IO ()+putMVar' m a = a `seq` putMVar m a -pureModifyMVar :: NFData a => MVar a -> (a -> a) -> IO ()-pureModifyMVar m f = do-	x <- takeMVar m-	putMVar' m (f x)+pureModifyMVar :: MVar a -> (a -> a) -> IO ()+pureModifyMVar m f = putMVar' m . f =<< takeMVar m 	 strict :: NFData a => a -> a strict x = x `deepseq` x

@@ -1,14 +1,12 @@ module Network.Tremulous.Scheduler(-	  Event, Scheduler-	, newScheduler, startScheduler, addScheduled, addScheduledBatch+	  Event(..), Scheduler+	, newScheduler, addScheduled, addScheduledBatch 	, addScheduledInstant, deleteScheduled ) where-import Prelude hiding (drop) import Control.Monad import Control.Concurrent import Control.Exception import Data.Typeable-import Data.Sequence import Data.Foldable import Network.Tremulous.MicroTime @@ -19,55 +17,46 @@  data (Eq id, Ord id) => Scheduler id a = Scheduler 	{ sync		:: !(MVar ())-	, started	:: !(MVar ())-	, queue		:: !(MVar (Seq (Event id a)))+	, queue		:: !(MVar [Event id a]) 	} -type Event id a = (MicroTime, id, a)---- ugly ugly ugly!-threadBlock :: IO ()-threadBlock = forever $ threadDelay maxBound--pureModifyMVar ::MVar a -> (a -> a) -> IO ()-pureModifyMVar m f = do-	x <- takeMVar m-	putMVar m (f x)+data Event id a = 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 throughput func finalizer = do -	queue		<- newMVar empty+	queue		<- newMVar [] 	sync		<- newEmptyMVar-	started		<- newEmptyMVar 	let sched	=  Scheduler{..} 	uninterruptibleMask $ \a -> forkIO $ runner sched a 	return sched 	 	where 	runner sched@Scheduler{..} restore = do-		takeMVar started+		takeMVar sync 		tid <- myThreadId 		let loop = do 			q <- takeMVar queue-			case viewl q of-				EmptyL -> case finalizer of+			case q of+				[] -> putMVar queue q >> case finalizer of 					Nothing -> do-						putMVar queue q-						ignoreException $ restore threadBlock+						takeMVar sync 						loop 					Just a -> a 					-				(0, idn, storage) :< qs -> do+				E{time=0, ..} : qs -> do 					putMVar queue qs 					func sched idn storage 					when (throughput > 0) 						(threadDelay throughput) 					loop 				-				(time, idn, storage) :< qs -> do+				E {..} : qs -> do 					now <- getMicroTime-					let wait = fromIntegral (time - now)-					if wait <= 0 then do+					if now >= time then do 						putMVar queue qs 						func sched idn storage 						when (throughput > 0)@@ -76,7 +65,8 @@ 						putMVar queue q 						tryTakeMVar sync 						syncid <- forkIOUnmasked $ takeMVar sync >> throwTo tid Interrupt-						waited <- falseOnException $ restore $ threadDelay wait+						let wait = fromIntegral (time - now)+						waited <- falseOnInterrupt $ restore $ threadDelay wait 						when waited $ do 							killThread syncid 							pureModifyMVar queue $ deleteID idn@@ -89,10 +79,7 @@ signal :: MVar () -> IO () signal a = tryPutMVar a () >> return () -startScheduler :: (Ord id, Eq id, Show id) => Scheduler id a -> IO ()-startScheduler Scheduler{..} = putMVar started ()--addScheduled :: (Ord id, Eq id, Show id) => Scheduler id a -> Event id a -> IO ()+addScheduled :: (Ord id, Eq id) => Scheduler id a -> Event id a -> IO () addScheduled Scheduler{..} event = do 	pureModifyMVar queue $ insertTimed event 	signal sync@@ -102,9 +89,9 @@ 	pureModifyMVar queue $ \q -> foldl' (flip insertTimed) q events 	signal sync -addScheduledInstant :: (Ord id, Eq id, Foldable f) => Scheduler id a -> f (id, a) -> IO ()+addScheduledInstant :: (Ord id, Eq id) => Scheduler id a -> [(id, a)] -> IO () addScheduledInstant Scheduler{..} events = do-	pureModifyMVar queue $ \q -> foldl' (\acc (a, b) -> (0, a, b) <| acc) q events+	pureModifyMVar queue $ \q -> (map (uncurry (E 0)) events) ++ q 	signal sync  deleteScheduled :: (Ord id, Eq id) => Scheduler id a -> id -> IO ()@@ -112,19 +99,21 @@ 	pureModifyMVar queue $ deleteID ident 	signal sync -ignoreException :: IO () -> IO ()-ignoreException = handle (\Interrupt -> return ()) -falseOnException :: IO a -> IO Bool-falseOnException f = handle (\Interrupt -> return False) (f >> return True)-+falseOnInterrupt :: IO a -> IO Bool+falseOnInterrupt f = handle (\Interrupt -> return False) (f >> return True) -insertTimed :: (Ord id, Eq id) => Event id a -> Seq (Event id a) -> Seq (Event id a)-insertTimed x@(a,_,_) q = (s1 |> x) >< s2 where-	(s1, s2) = spanl (\(b,_,_) -> a >= b) q+insertTimed :: (Ord id, Eq id) => Event id a -> [Event id a] -> [Event id a]+insertTimed e (x:xs)+	| time e >= time x	= x : insertTimed e xs+	| otherwise		= e : x : xs+insertTimed e []		= [e] +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, Eq id) => id -> Seq (Event id a) -> Seq (Event id a)-deleteID ident q = s1 >< s2' where-	(s1, s2) = spanl (\(_,a,_) -> a /= ident) q-	s2' = drop 1 s2 +pureModifyMVar ::MVar a -> (a -> a) -> IO ()+pureModifyMVar m f = putMVar m . f =<< takeMVar m

@@ -13,19 +13,22 @@ 	roll []			= (Nothing, []) 	roll (x@(a, b):xs) 		| key == a	= (Just b, xs)-		| otherwise	= let (may, xs') = roll xs in (may, x:xs')+		| otherwise	= let ~(may, xs') = roll xs in (may, x:xs')  require :: Eq k => k -> TupleReader k v v-require key = get >>= \s -> case lookupDelete key s of-	(Nothing, _)	-> lift Nothing-	(Just a, s')	-> put s' >> return a+require key = with key >>= lift  requireWith :: Eq k => (v -> Maybe a) -> k -> TupleReader k v a-requireWith f key = get >>= \s -> case lookupDelete key s of-	(Nothing, _)	-> lift Nothing-	(Just a, s')	-> put s' >> lift (f a)+requireWith f key = do+	e <- with key+	lift $ f =<< e  option :: Eq k => a -> (v -> a) -> k -> TupleReader k v a-option def f key = get >>= \s -> case lookupDelete key s of-	(Nothing, _)	-> return def-	(Just a, s')	-> put s' >> return (f a)+option def f key = maybe def f `fmap` with key++with :: Eq k => k -> TupleReader k v (Maybe v)+with key = do+	s <- get+	let (e, s') = lookupDelete key s+	put s'+	return e

@@ -25,7 +25,7 @@  search :: String -> [GameServer] -> [(TI, GameServer)] search ""	= makePlayerNameList -search rawstr	= filter (\(a,_) -> str `B.isInfixOf` cleanedCase a ) . makePlayerNameList +search rawstr	= filter (\(a, _) -> str `B.isInfixOf` cleanedCase a ) . makePlayerNameList  	where 	str	= B.pack $ map toLower rawstr 	

@@ -1,5 +1,5 @@ Name:			tremulous-query-Version:		1.0.2+Version:		1.0.3 Author:			Christoffer Öjeling Maintainer:		Christoffer Öjeling <christoffer@ojeling.net> License:		GPL-3