packages feed

tremulous-query 1.0.3 → 1.0.4

raw patch · 11 files changed

+293/−234 lines, 11 files

Files

Network/Tremulous/ByteStringUtils.hs view
@@ -1,25 +1,47 @@ module Network.Tremulous.ByteStringUtils where-import Prelude as P-import Control.Applicative-import Control.DeepSeq-import Data.ByteString.Char8 as B+import qualified Prelude as P+import Prelude hiding (length, Maybe(..), null, dropWhile, drop)+import Data.ByteString.Char8 import Data.Char--instance NFData ByteString +import Network.Tremulous.StrictMaybe+import Data.ByteString.Internal+import Foreign  stripPrefix :: ByteString -> ByteString -> Maybe ByteString stripPrefix p xs-	| p `isPrefixOf` xs	= Just $ B.drop (B.length p) xs-	| otherwise		= Nothing	+	| p `isPrefixOf` xs	= Just $ drop (length p) xs+	| otherwise		= Nothing  maybeInt :: ByteString -> Maybe Int-maybeInt x = fst <$> readInt x+maybeInt x = case readInt x of+	P.Nothing	-> Nothing+	P.Just (a, _)	-> Just a  splitlines :: ByteString -> [ByteString] splitlines = splitfilter '\n'  stripw :: ByteString -> ByteString-stripw = B.dropWhile isSpace+stripw = dropWhile isSpace  splitfilter :: Char -> ByteString -> [ByteString]-splitfilter f = P.filter (not . B.null) . split f+splitfilter f = P.filter (not . null) . split f+++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)++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)
Network/Tremulous/MicroTime.hs view
@@ -16,7 +16,7 @@ #ifdef mingw32_HOST_OS getMicroTime = do 	FILETIME ft <- System.Win32.Time.getSystemTimeAsFileTime-	return ((ft - win32_epoch_adjust) `div` 10)+	return ((ft - win32_epoch_adjust) `quot` 10)  win32_epoch_adjust :: Word64 win32_epoch_adjust = 116444736000000000
Network/Tremulous/NameInsensitive.hs view
@@ -1,46 +1,47 @@ module Network.Tremulous.NameInsensitive (-	TI(..), mk, mkColor, mkAlphaNum, unpackorig+	TI(..), mk, mkColor, mkAlphaNum ) where-import Control.DeepSeq-import Data.ByteString.Char8 as B+import Prelude hiding (length, map, filter)+import Data.ByteString.Char8 import Data.Char import Data.Ord+import Network.Tremulous.ByteStringUtils -data TI = TI { -	  original :: !ByteString-	, cleanedCase :: !ByteString+data TI = TI {+	  original	:: !ByteString+	, cleanedCase	:: !ByteString 	} --- Already strict-instance NFData TI- instance Eq TI where 	a == b = cleanedCase a == cleanedCase b-	+ instance Ord TI where 	compare = comparing cleanedCase-	+ instance Show TI where 	show = show . original -unpackorig :: TI -> String-unpackorig = B.unpack . original-	 mk :: ByteString -> TI-mk bs = TI bs (B.map toLower bs)+mk xs = TI bs (map toLower bs)+	where bs = clean xs  mkColor :: ByteString -> TI-mkColor bs = TI bs (B.map toLower $ removeColors bs)+mkColor xs = TI bs (removeColors bs)+	where bs = clean xs  mkAlphaNum :: ByteString -> TI-mkAlphaNum bs = TI bs (B.map toLower $ B.filter isAlphaNum bs)+mkAlphaNum xs = TI bs (map toLower $ filter (\x -> isAlphaNum x || isSpace x) bs)+	where bs = clean xs +clean :: ByteString -> ByteString+clean = stripw . filter (\c -> c >= '\x20' && c <= '\x7E')+ removeColors :: ByteString -> ByteString-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+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)
Network/Tremulous/Polling.hs view
@@ -1,22 +1,21 @@ module Network.Tremulous.Polling ( 	pollMasters, pollOne ) where-import Prelude hiding (all, concat, mapM_, elem, sequence_, concatMap, catch)+import Prelude hiding (all, concat, mapM_, elem, sequence_, concatMap, catch, Maybe(..), maybe, foldr)+import qualified Data.Maybe as P -import Control.DeepSeq-import Control.Monad hiding (mapM_, sequence_)+import Control.Monad (when) import Control.Concurrent import Control.Applicative import Control.Exception  import Data.Foldable-import Data.Set (Set)-import qualified Data.Set as S import Data.Map (Map) import qualified Data.Map as M import Data.String import Data.ByteString.Char8 (ByteString, append, pack) +import Network.Tremulous.StrictMaybe import Network.Socket hiding (send, sendTo, recv, recvFrom) import Network.Socket.ByteString import Network.Tremulous.Protocol@@ -24,7 +23,8 @@ import Network.Tremulous.MicroTime import Network.Tremulous.Scheduler -data QType = QMaster !Int !Int | QGame !Int | QJustWait deriving Show+data QType = QMaster !Int !Int | QGame !Int | QJustWait+data State = Pending MasterServer | Requested !MicroTime MasterServer | Responded | Broken  mtu :: Int mtu = 2048@@ -34,101 +34,105 @@ getServers :: Int -> ByteString getServers proto = "\xFF\xFF\xFF\xFFgetservers " `append` pack (show proto) `append` " empty full" + pollMasters :: Delay -> [MasterServer] -> IO PollResult pollMasters Delay{..} masterservers = do 	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-	tstate		<- newMVar S.empty-	-	-- When first packet was sent to server (removed on proper response)-	pingstate	<- newMVar (M.empty :: Map SockAddr MicroTime) +	state		<- newMVar (M.empty :: Map SockAddr State)+ 	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 pingstate $ M.insert host now+				pureModifyMVar state $ M.update (\x -> case x of+					Pending ms -> P.Just (Requested now ms)+					_          -> P.Nothing)+					host 			sendTo sock getStatus host-			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-			+			addScheduled sched $ if (n > 0)+				then E (now + fromIntegral packetTimeout) host (QGame (n-1))+				else E (now + fromIntegral packetTimeout) host QJustWait+ 		QMaster n proto	-> do 			now <- getMicroTime 			sendTo sock (getServers proto) host-			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-				+			addScheduled sched $ if (n > 0)+				then E (now + fromIntegral packetTimeout `quot` 2) host (QMaster (n-1) proto)+				else E (now + fromIntegral packetTimeout) host QJustWait+ 		QJustWait -> return ()-		+ 	sched		<- newScheduler throughputDelay sf (Just (putMVar finished () >> sClose sock)) 	addScheduledInstant sched $ 		map (\MasterServer{..} -> (masterAddress, QMaster (packetDuplication*4) masterProtocol)) masterservers  	let buildResponse = do 		packet <- forceIO finished $ recvFrom sock mtu-		case parsePacket (map masterAddress masterservers) <$> packet of+		now <- getMicroTime+		case parsePacket <$> 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-				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)-				-				buildResponse+			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 +				P.Nothing -> buildResponse+ 			Just (Tremulous host x) -> do-				now <- getMicroTime-				t <- takeMVar tstate-				if S.member host t then do-					putMVar' tstate t-					buildResponse-				else do-					deleteScheduled sched host-					ps	<- takeMVar pingstate-					start	<- return $! M.lookup host ps-					putMVar' pingstate $ M.delete host ps-					putMVar' tstate $ S.insert host t-					-- This also serves as protection against-					-- receiving responses for requests never sent-					case start of-						Nothing -> buildResponse-						Just a	-> do-							let gameping = fromIntegral (now - a) `div` 1000-							( strict x{ gameping } : ) `liftM` buildResponse			+				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-			+ 			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 +	s	<- takeMVar state+	let (nResp, nNot) = ssum s+	return (PollResult xs nResp (nResp+nNot))++	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) -data Packet = Master !SockAddr !(Set SockAddr) | Tremulous !SockAddr !GameServer | Invalid -parsePacket :: [SockAddr] -> (ByteString, SockAddr) -> Packet-parsePacket masters (content, host) = case B.stripPrefix "\xFF\xFF\xFF\xFF" content of-	Just a	| Just x <- parseServer a			-> Tremulous host x-		| Just x <- parseMaster a, host `elem` masters	-> Master host x-	_							-> Invalid+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 = S.fromList . parseMasterServer <$> stripPrefix "getserversResponse" x+	parseMaster x = parseMasterServer <$> stripPrefix "getserversResponse" x 	parseServer x = parseGameServer host =<< stripPrefix "statusResponse" x  @@ -143,12 +147,12 @@ 		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}) <$> +	let gameping = fromIntegral (stop - start) `quot` 1000+	return $ (\x -> x {gameping}) <$> 		(parseGameServer sockaddr =<< isProper =<< poll) 	where 	err (_ :: IOError) = return Nothing@@ -156,18 +160,3 @@  ioMaybe :: IO a -> IO (Maybe a) ioMaybe f = catch (Just <$> f) (\(_ :: IOError) -> return Nothing)--putMVar' :: MVar a -> a -> IO ()-putMVar' m a = a `seq` putMVar m a--pureModifyMVar :: MVar a -> (a -> a) -> IO ()-pureModifyMVar m f = putMVar' m . f =<< takeMVar m-	-strict :: NFData a => a -> a-strict x = x `deepseq` x--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 ()-
Network/Tremulous/Protocol.hs view
@@ -2,26 +2,21 @@ 	  module Network.Tremulous.NameInsensitive 	, Delay(..), Team(..),  GameServer(..), Player(..), MasterServer(..), PollResult(..) 	, defaultDelay, parseGameServer, proto2string, string2proto, parseMasterServer-	, B.unpack ) where-import Prelude as P-import Control.Applicative-import Control.DeepSeq+import Prelude as P hiding (Maybe(..), maybe)+import Control.Applicative hiding (many) import Control.Monad.State.Strict -import Data.Attoparsec.Char8 as A hiding (option)+import Data.Attoparsec.Char8 hiding (option) import Data.Attoparsec (anyWord8) import Data.ByteString.Char8 as B-import Data.Maybe+import Network.Tremulous.StrictMaybe import Data.String-import Data.Char import Data.Bits import Data.Word-import Data.Set (Set)- import Network.Socket import Network.Tremulous.ByteStringUtils as B-import Network.Tremulous.SocketExtensions ()+import Network.Tremulous.SocketExtensions import Network.Tremulous.NameInsensitive import Network.Tremulous.TupleReader @@ -29,26 +24,28 @@ 	  packetTimeout 	, packetDuplication 	, throughputDelay	:: !Int-	} deriving (Show, Read)+	}  data MasterServer = MasterServer { 	   masterAddress	:: !SockAddr 	 , masterProtocol	:: !Int 	} deriving Eq-	+ data GameServer = GameServer { 	  address	:: !SockAddr-	, gameping	:: !Int+	, gameping 	, protocol	:: !Int-	, gamemod	:: !(Maybe TI) 	, hostname	:: !TI-	, mapname	:: !TI-	, slots-	, privslots	:: !Int-	, protected	:: !Bool+	, gamemod+	, version+	, mapname	:: !(Maybe TI)+	, slots		:: !Int+	, privslots	:: !(Maybe Int)+	, protected+	, unlagged	:: !Bool 	, timelimit 	, suddendeath	:: !(Maybe Int)-	, unlagged	:: !Bool+ 	, nplayers	:: !Int 	, players	:: ![Player] 	}@@ -66,30 +63,15 @@ 	  polled		:: ![GameServer] 	, serversResponded 	, serversRequested	:: !Int-	, respondedCache	:: !(Set SockAddr) 	} --instance NFData MasterServer where-	rnf (MasterServer a b) = rnf a `seq` rnf b--instance NFData Team--instance NFData GameServer where-	rnf (GameServer a b c d e f g h i j k l m n) = rnf a `seq` rnf b `seq` rnf c `seq` rnf d-		`seq` rnf e `seq` rnf f `seq` rnf g `seq` rnf h `seq` rnf i `seq` rnf j -		`seq` rnf k `seq` rnf l `seq` rnf m `seq` rnf n--instance NFData Player where-	rnf (Player a b c d)  = rnf a `seq` rnf b `seq` rnf c `seq` rnf d- defaultDelay :: Delay defaultDelay = Delay { 	  packetTimeout		= 400 * 1000 	, packetDuplication	= 2 	, throughputDelay	= 1 * 1000 	}-	+ -- Protocol version proto2string :: IsString s => Int ->  s proto2string x = case x of@@ -111,27 +93,28 @@ 	skipSpace 	ping <- signed decimal 	skipSpace-	name <- mkColor . clean <$> quoted+	name <- mkColor <$> quoted 	return Player {..}-	+ -- cvar P parseP :: ByteString -> [Team]-parseP = foldr' f [] +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 :: ByteString -> [ByteString] -> Maybe [Player]-parsePlayers p = zipWithM parsePlayer (parseP p ++ repeat 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 +parseCVars xs = f (splitfilter '\\' xs) where 	f (k:v:cs)	= (k, v) : f cs 	f _		= [] @@ -142,45 +125,47 @@  mkGameServer :: SockAddr -> [ByteString] -> [(ByteString, ByteString)] -> Maybe GameServer mkGameServer address rawplayers = tupleReader $ do-	timelimit	<- option Nothing maybeInt "timelimit"-	hostname	<- mkColor . clean <$> require "sv_hostname"-	protocol	<- requireWith maybeInt "protocol"-	mapname		<- option (TI "" "") (mk . clean) "mapname"-	gamemod		<- option Nothing mkMod "gamename"-	p		<- option "" id "P"+	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	<- option False (/="0") "g_needpass"-	privslots	<- option 0 (fromMaybe 0 . maybeInt) "sv_privateClients"-	slots		<- requireWith maybeInt "sv_maxclients"-	suddendeath	<- option Nothing maybeInt "g_suddenDeathTime"-	unlagged	<- option False (/="0") "g_unlagged"-	+	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"+ 	return GameServer { gameping = -1, nplayers = P.length players, .. } 	where 	mkMod "base"	= Nothing-	mkMod a		= Just (mk (clean a))+	mkMod a		= Just (mk a)  -parseMasterServer :: ByteString -> [SockAddr]	-parseMasterServer = fromMaybe [] . parseMaybe attoIP+parseMasterServer :: ByteString -> [SockAddr]+parseMasterServer = fromMaybe [] . parseMaybe (many addr) 	where-	attoIP = A.many (char '\\' *> addr)-	(.<<.) :: Bits a => a -> Int -> a-	(.<<.) = shiftL		-	wg :: Integral i => Parser i-	wg = fromIntegral <$> anyWord8	+	wg = anyWord8+	f :: (Integral a, Integral b) => a -> b+	f = fromIntegral 	addr = do-		-- try $ string "EOT\0\0\0" *> endOfInput-		i0 <- wg-		i1 <- wg-		i2 <- wg+		char '\\' 		i3 <- wg-		p0 <- wg+		i2 <- wg+		i1 <- wg+		i0 <- wg 		p1 <- wg-		let ip = (i3 .<<. 24) .|. (i2 .<<. 16) .|. (i1 .<<. 8) .|. i0 :: Word32-		let port = (p0 .<<. 8) .|. p1 :: Word16-		return $ SockAddrInet (fromIntegral port) ip-+		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 ////////////////////////////////////////////////////////////////////////////  quoted :: Parser ByteString@@ -190,6 +175,3 @@ parseMaybe f xs = case parseOnly f xs of 	Right a	-> Just a 	Left _	-> Nothing--clean :: ByteString -> ByteString-clean = stripw . B.filter isPrint
Network/Tremulous/Scheduler.hs view
@@ -2,7 +2,10 @@ 	  Event(..), Scheduler 	, newScheduler, addScheduled, addScheduledBatch 	, addScheduledInstant, deleteScheduled+	, putMVar', pureModifyMVar ) where+import Prelude hiding (Maybe(..))+import Network.Tremulous.StrictMaybe import Control.Monad import Control.Concurrent import Control.Exception@@ -12,13 +15,13 @@  data Interrupt = Interrupt 	deriving (Typeable, Show)-	+ instance Exception Interrupt -data (Eq id, Ord id) => Scheduler id a = Scheduler-	{ sync		:: !(MVar ())-	, queue		:: !(MVar [Event id a])-	}+data Scheduler id a = (Eq id, Ord id) =>+	Scheduler	{ sync		:: !(MVar ())+			, queue		:: !(MVar [Event id a])+			}  data Event id a = E 	{ time		:: !MicroTime@@ -27,13 +30,13 @@ 	}  newScheduler :: (Eq a, Ord a) => Int -> (Scheduler a b -> a -> b -> IO ()) -> Maybe (IO ()) -> IO (Scheduler a b)-newScheduler throughput func finalizer = do +newScheduler throughput func finalizer = do 	queue		<- newMVar [] 	sync		<- newEmptyMVar 	let sched	=  Scheduler{..} 	uninterruptibleMask $ \a -> forkIO $ runner sched a 	return sched-	+ 	where 	runner sched@Scheduler{..} restore = do 		takeMVar sync@@ -41,28 +44,28 @@ 		let loop = do 			q <- takeMVar queue 			case q of-				[] -> putMVar queue q >> case finalizer of+				[] -> putMVar' queue q >> case finalizer of 					Nothing -> do 						takeMVar sync 						loop 					Just a -> a-					+ 				E{time=0, ..} : qs -> do-					putMVar queue qs+					putMVar' queue qs 					func sched idn storage 					when (throughput > 0) 						(threadDelay throughput) 					loop-				+ 				E {..} : qs -> do 					now <- getMicroTime 					if now >= time then do-						putMVar queue qs+						putMVar' queue qs 						func sched idn storage 						when (throughput > 0) 							(threadDelay throughput) 					else do-						putMVar queue q+						putMVar' queue q 						tryTakeMVar sync 						syncid <- forkIOUnmasked $ takeMVar sync >> throwTo tid Interrupt 						let wait = fromIntegral (time - now)@@ -79,22 +82,22 @@ signal :: MVar () -> IO () signal a = tryPutMVar a () >> return () -addScheduled :: (Ord id, Eq id) => Scheduler id a -> Event id a -> IO ()+addScheduled :: Scheduler id a -> Event id a -> IO () addScheduled Scheduler{..} event = do 	pureModifyMVar queue $ insertTimed event 	signal sync-	-addScheduledBatch :: (Ord id, Eq id, Foldable f) => Scheduler id a -> f (Event id a) -> IO ()++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 -addScheduledInstant :: (Ord id, Eq id) => Scheduler id a -> [(id, a)] -> IO ()+addScheduledInstant :: Scheduler id a -> [(id, a)] -> IO () addScheduledInstant Scheduler{..} events = do 	pureModifyMVar queue $ \q -> (map (uncurry (E 0)) events) ++ q 	signal sync -deleteScheduled :: (Ord id, Eq id) => Scheduler id a -> id -> IO ()+deleteScheduled :: Scheduler id a -> id -> IO () deleteScheduled Scheduler{..} ident = do 	pureModifyMVar queue $ deleteID ident 	signal sync@@ -115,5 +118,9 @@ 		| otherwise		-> x : deleteID match xs 	[]				-> [] -pureModifyMVar ::MVar a -> (a -> a) -> IO ()-pureModifyMVar m f = putMVar m . f =<< takeMVar m+putMVar' :: MVar a -> a -> IO ()+putMVar' m !a = putMVar m a++pureModifyMVar :: MVar a -> (a -> a) -> IO ()+pureModifyMVar m f = putMVar' m . f =<< takeMVar m+
Network/Tremulous/SocketExtensions.hs view
@@ -1,15 +1,26 @@ {-# LANGUAGE CPP, StandaloneDeriving #-} module Network.Tremulous.SocketExtensions where+import Prelude as P+import Foreign import Control.DeepSeq import Network.Socket  deriving instance Ord SockAddr  instance NFData SockAddr where-	rnf (SockAddrInet (PortNum p) h) 	= rnf p `seq` rnf h-	rnf (SockAddrInet6 (PortNum p) f h s)	= rnf p `seq` rnf f `seq` rnf h `seq` rnf s-#ifdef linux_HOST_OS-	rnf (SockAddrUnix s)			= rnf s+	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 #endif-	 +#if defined(mingw32_HOST_OS) || defined(__MINGW32__)+#define CALLCONV stdcall+#else+#define CALLCONV ccall+#endif++foreign import CALLCONV unsafe "ntohl" ntohl :: Word32 -> Word32+foreign import CALLCONV unsafe "htonl" htonl :: Word32 -> Word32+foreign import CALLCONV unsafe "ntohs" ntohs :: Word16 -> Word16+foreign import CALLCONV unsafe "htons" htons :: Word16 -> Word16
+ Network/Tremulous/StrictMaybe.hs view
@@ -0,0 +1,43 @@+{- Drop in replacement for Data.Maybe+-- It was easier to just use this than messing around with seq+-}+module Network.Tremulous.StrictMaybe where+import Prelude hiding(Maybe(..), maybe)++data Maybe a = Nothing | Just !a+	deriving (Eq, Ord, Show, Read)++instance Functor Maybe where+	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++isJust :: Maybe a -> Bool+isJust Nothing		= False+isJust _		= True++isNothing :: Maybe a -> Bool+isNothing Nothing	= True+isNothing _		= False++fromMaybe :: a -> Maybe a -> a+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++whenJust :: Monad m => Maybe t -> (t -> m ())-> m ()+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 ()
Network/Tremulous/TupleReader.hs view
@@ -1,7 +1,7 @@-module Network.Tremulous.TupleReader (-	TupleReader, tupleReader, require, requireWith, option-) where+module Network.Tremulous.TupleReader where import Control.Monad.State.Strict+import Network.Tremulous.StrictMaybe+import Prelude (Eq(..), otherwise, ($))  type TupleReader k v a = StateT [(k, v)] Maybe a @@ -23,10 +23,13 @@ 	e <- with key 	lift $ f =<< e -option :: Eq k => a -> (v -> a) -> k -> TupleReader k v a-option def f key = maybe def f `fmap` with key+optionWith :: Eq k => (v -> Maybe a) -> k -> TupleReader k v (Maybe a)+optionWith f key = do+	e <- with key+	return (f =<< e) -with :: Eq k => k -> TupleReader k v (Maybe v)+with, option :: Eq k => k -> TupleReader k v (Maybe v)+option = with with key = do 	s <- get 	let (e, s') = lookupDelete key s
Network/Tremulous/Util.hs view
@@ -24,11 +24,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 +search ""	= makePlayerNameList+search rawstr	= filter (\(a, _) -> str `B.isInfixOf` cleanedCase a ) . makePlayerNameList 	where 	str	= B.pack $ map toLower rawstr-	+ makePlayerNameList :: [GameServer] -> [(TI, GameServer)] makePlayerNameList = concatMap $ \x -> map (\a -> (name a, x)) (players x)
tremulous-query.cabal view
@@ -1,5 +1,5 @@ Name:			tremulous-query-Version:		1.0.3+Version:		1.0.4 Author:			Christoffer Öjeling Maintainer:		Christoffer Öjeling <christoffer@ojeling.net> License:		GPL-3@@ -19,7 +19,7 @@  Library   Default-Language:     Haskell2010-  Default-Extensions:   BangPatterns TupleSections NamedFieldPuns RecordWildCards+  Default-Extensions:   BangPatterns TupleSections NamedFieldPuns RecordWildCards GADTs                         ScopedTypeVariables OverloadedStrings DeriveDataTypeable   Other-Extensions:     CPP StandaloneDeriving   Exposed-Modules:      Network.Tremulous.Protocol@@ -30,9 +30,10 @@                         Network.Tremulous.ByteStringUtils                         Network.Tremulous.Scheduler                         Network.Tremulous.MicroTime-  Other-Modules:        Network.Tremulous.TupleReader+                        Network.Tremulous.StrictMaybe+                        Network.Tremulous.TupleReader -  Build-Depends:        base>=4.3 && < 5, network, deepseq, containers, bytestring, attoparsec, mtl+  Build-Depends:        base>=4.3 && < 5, network, containers, bytestring, attoparsec, mtl, deepseq   if os(windows)       Build-Depends:    Win32   Ghc-Options:          -Wall -fno-warn-unused-do-bind -fno-warn-orphans -funbox-strict-fields