packages feed

apelsin 1.0 → 1.1

raw patch · 19 files changed

+598/−386 lines, 19 filesdep ~tremulous-query

Dependency ranges changed: tremulous-query

Files

apelsin.cabal view
@@ -1,5 +1,5 @@ Name:                   apelsin-Version:                1.0+Version:                1.1 Author:                 Christoffer Öjeling Maintainer:             christoffer@ojeling.net License:                GPL-3@@ -37,10 +37,11 @@   Other-Extensions:     CPP   Build-Depends:        base>=4.3&&<5, array, mtl, stm, containers, transformers,                         bytestring, directory, filepath, HTTP, network,-                        tremulous-query, gtk, glib, process+                        tremulous-query>=1.0.2, gtk, glib, process   Hs-Source-Dirs:       src   Main-is:              Apelsin.hs   Other-Modules:        System.Environment.XDG.BaseDir+                        GtkExts                         About                         ClanFetcher                         Clanlist
src/About.hs view
@@ -5,11 +5,12 @@ newAbout :: WindowClass w => w -> IO () newAbout win = do 	about <- aboutDialogNew+	aboutDialogSetUrlHook openInBrowser 	set about [ 		  windowWindowPosition := WinPosCenterOnParent 		, windowTransientFor	:= win 		, aboutDialogProgramName:= programName-		, aboutDialogVersion	:= "1.0"+		, aboutDialogVersion	:= "1.1" 		, aboutDialogCopyright	:= "Copyright © 2011\nChristoffer Öjeling <christoffer@ojeling.net>" 		, aboutDialogComments	:= "A tremulous server and community browser\nLicense: GPLv3" 		, aboutDialogWebsite	:= "http://ojeling.net"
src/Apelsin.hs view
@@ -5,6 +5,7 @@ import Control.Monad.IO.Class import Control.Exception import Control.Monad+import Data.Char (toLower) import qualified Data.Set as S import Network.Socket import Network.Tremulous.Protocol@@ -28,36 +29,40 @@ 	win		<- windowNew 	config		<- configFromFile 	cacheclans	<- clanListFromCache-	bundle		<- atomically $ Bundle-				<$> newTMVar (PollResult [] 0 0 S.empty)-				<*> newTMVar config-				<*> newTMVar cacheclans-				<*> pure win--	(currentInfo, currentUpdate, currentSet)<- newServerInfo bundle-	(browser, browserUpdate)		<- newServerBrowser bundle currentSet-	(findPlayers, findUpdate)		<- newFindPlayers bundle currentSet-	(clanlist, clanlistUpdate)		<- newClanList bundle+	bundle	<-	(do+			mpolled		<- atomically $ newTMVar (PollResult [] 0 0 S.empty)+			mconfig		<- atomically $ newTMVar config+			mclans		<- atomically $ newTMVar cacheclans+			browserStore	<- listStoreNew []+			return Bundle {parent = win, ..}+			)+	mupdate <- atomically newEmptyTMVar+	(currentInfo, currentUpdate, currentSet)<- newServerInfo bundle mupdate+	(browser, browserUpdate, ent0)		<- newServerBrowser bundle currentSet+	(findPlayers, findUpdate, ent1)		<- newFindPlayers bundle currentSet+	(clanlist, clanlistUpdate, ent3)	<- newClanList bundle cacheclans currentSet 	(onlineclans, onlineclansUpdate)	<- newOnlineClans bundle currentSet  	preferences				<- newPreferences bundle+	atomically $ putTMVar mupdate (findUpdate, onlineclansUpdate)  	toolbar <- newToolbar bundle-		(clanlistUpdate >> onlineclansUpdate)-		(browserUpdate >> findUpdate >> currentUpdate >> onlineclansUpdate)+		[]+		[browserUpdate, findUpdate, currentUpdate]+		[onlineclansUpdate, clanlistUpdate]  	-- /// Layout ////////////////////////////////////////////////////////////////////////////  	book <- notebookNew-	notebookAppendMnemonic book browser	"_1: Browser"-	notebookAppendMnemonic book findPlayers	"_2: Find players"-	notebookAppendMnemonic book onlineclans	"_3: Online clans"-	notebookAppendMnemonic book clanlist	"_4: Clan list"-	notebookAppendMnemonic book preferences	"_5: Preferences"+	notebookAppendPage book browser		"Browser"+	notebookAppendPage book findPlayers	"Find players"+	notebookAppendPage book onlineclans	"Online clans"+	notebookAppendPage book clanlist	"Clan list"+	notebookAppendPage book preferences	"Preferences" 	leftView <- vBoxNew False 0 	boxPackStart leftView toolbar PackNatural 0 	boxPackStart leftView book PackGrow 0-+	  	pane <- hPanedNew 	panedPack1 pane leftView True False@@ -75,7 +80,7 @@ 		mainQuit  	ddir <- getDataDir-	handleGError (const $ trace $ "Window icon not found: " ++ ddir) $ do+	handleGError (const $ trace $ "Window icon not found in: " ++ ddir) $ do 		let list = map 			(\x -> joinPath [ddir, "icons", "hicolor", x ++ "x" ++ x, "apps", "apelsin.png"]) 			["16", "32", "48", "64"]@@ -104,8 +109,27 @@ 				, widgetWidthRequest	:= max (minw+panebuf) winw ] 	widgetShowAll win --+	on win keyPressEvent $  do+		kmod	<- eventModifier+		k	<- map toLower <$> eventKeyName+		case kmod of+			[Alt]	| Just page <- mread k+				, page >= 1+				, page <= 5+				-> do	liftIO (set book [ notebookPage := page - 1])+					return True+			[Control]+				| k == "l" || k == "f"+				-> do	page <- liftIO (get book notebookPage)+					case page of+						0 -> liftIO $ widgetGrabFocus ent0+						1 -> liftIO $ widgetGrabFocus ent1+						3 -> liftIO $ widgetGrabFocus ent3+						_ -> return ()+					return True+			_ -> return False+			+	widgetGrabFocus ent0 	mainGUI
src/ClanFetcher.hs view
@@ -1,5 +1,5 @@ module ClanFetcher( -	Clan(..), TagExpr, matchTagExpr, getClanList, clanListFromCache+	Clan(..), TagExpr, matchTagExpr, prettyTagExpr, tagExprGet, getClanList, clanListFromCache ) where  import Prelude as P hiding (catch)@@ -8,60 +8,84 @@ import Control.Monad import Data.ByteString.Char8 as B import Data.ByteString.Lazy.Char8 as L-import Data.Char (intToDigit, toLower)+import Data.Char (intToDigit) import Data.Maybe+import Data.Ord+import Network.Socket import Network.HTTP import Network.URI import Network.Tremulous.NameInsensitive+import TremFormatting  import Constants  data TagExpr =-	  TagPrefix !B.ByteString-	| TagSuffix !B.ByteString-	| TagInfix !B.ByteString-	| TagContained !B.ByteString !B.ByteString-	| TagError+	  TagPrefix !TI+	| TagSuffix !TI+	| TagInfix !TI+	| TagContained !TI !TI+	deriving Eq +instance Ord TagExpr where+	compare = comparing tagExprGet++tagExprGet :: TagExpr -> B.ByteString+tagExprGet x = case x of+	TagPrefix (TI _ v)	-> v+	TagSuffix (TI _ v)	-> v+	TagInfix (TI _ v)	-> v+	TagContained (TI _ v) _	-> v+ data Clan = Clan {-	  clanid	:: !B.ByteString-	, name-	, tag		:: !TI+	  name		:: !TI 	, website 	, irc		:: !B.ByteString 	, tagexpr	:: !TagExpr+	, clanserver	:: !(Maybe SockAddr) 	} -mkTagExpr :: B.ByteString -> TagExpr+mkTagExpr :: B.ByteString -> Maybe TagExpr mkTagExpr str-	| B.length str > 0 = case x of-	'<' -> TagPrefix xs-	'>' -> TagSuffix xs-	'^' -> TagInfix xs-	'%' -> let (a, b) = B.break (=='%') xs in TagContained a (B.drop 1 b)-	_   -> TagError-	| otherwise = TagError-	where	(x, xs)	= (B.head str, B.map toLower (B.tail str))+	| Just (x, xs) <- B.uncons str = case x of+		'<' -> Just (TagPrefix (mk xs))+		'>' -> Just (TagSuffix (mk xs))+		'^' -> Just (TagInfix (mk xs))+		'%' -> let (a, b) = B.break (=='%') xs+				in Just (TagContained (mk a) (mk (B.drop 1 b)))+		_   -> Nothing+	| otherwise = Nothing  matchTagExpr :: TagExpr -> TI -> Bool matchTagExpr expr raw = case expr of-	TagPrefix xs		-> xs `B.isPrefixOf` str-	TagSuffix xs		-> xs `B.isSuffixOf` str-	TagInfix xs		-> xs `B.isInfixOf` str-	TagContained xs ys	-> xs `B.isPrefixOf` str && ys `B.isSuffixOf` str-	TagError		-> False+	TagPrefix (TI _ xs)		-> xs `B.isPrefixOf` str+	TagSuffix (TI _ xs)		-> xs `B.isSuffixOf` str+	TagInfix (TI _ xs)		-> xs `B.isInfixOf` str+	TagContained (TI _ xs) (TI _ ys)-> xs `B.isPrefixOf` str && ys `B.isSuffixOf` str 	where str = cleanedCase raw +prettyTagExpr :: TagExpr -> String+prettyTagExpr expr = case expr of+	TagPrefix bs	-> esc bs ++ wild+	TagSuffix bs	-> wild ++ esc bs+	TagInfix bs	-> wild ++ esc bs ++ wild+	TagContained a b-> esc a ++ wild ++ esc b+	where	wild = "<span color=\"#BBB\">*</span>"+		esc  = htmlEscape . B.unpack . original -rawToClan :: L.ByteString -> Maybe [Clan]-rawToClan = mapM (f . B.split '\t' . lazyToStrict) . P.filter (not . L.null) . L.split '\n' where -	f [clanid, rname, rtag, website, irc, rexpr, _] =-		Just Clan	{ name = mkAlphaNum rname-				, tag = mk rtag-				, tagexpr = mkTagExpr rexpr-				, .. }-	f _	= Nothing +rawToClan :: L.ByteString -> IO (Maybe [Clan])+rawToClan = fmap sequence . mapM (f . B.split '\t' . lazyToStrict) . P.filter (not . L.null) . L.split '\n' where +	f [_, rname, _, website, irc, rexpr, rserver]+		| Just tagexpr <- mkTagExpr rexpr+		= do+			let	(ip, port1)	= B.break (==':') rserver+				port		= B.drop 1 port1+			clanserver <- if B.null ip || B.null port+				then return Nothing+				else getDNS (B.unpack ip) (B.unpack port)+			return $ Just Clan { name = mkAlphaNum rname, .. }+	f _	= return Nothing+ getClanList :: String -> IO (Maybe [Clan]) getClanList url = do 	cont <- get url@@ -69,7 +93,7 @@ 		Right _ -> return Nothing 		Left raw -> do 			file	<- inCacheDir "clans"-			let clans = rawToClan raw+			clans	<- rawToClan raw 			when (isJust clans) $ 				L.writeFile file raw @@ -79,9 +103,9 @@ clanListFromCache :: IO [Clan] clanListFromCache = handle err $ do 	file	<- inCacheDir "clans"-	fromMaybe [] . rawToClan <$> L.readFile file+	fromMaybe [] <$> (rawToClan =<< L.readFile file) 	where-	err (_::IOError) = return [] +	err (_ :: IOError) = return []  	  lazyToStrict :: L.ByteString -> B.ByteString		@@ -104,3 +128,8 @@ 	getRight (Left _) = error "" 	err :: IOException -> IO (Either String a ) 	err = return . Left . show++getDNS :: String -> String -> IO (Maybe SockAddr)+getDNS host port = handle (\(_ :: IOException) -> return Nothing) $ do+	AddrInfo _ _ _ _ addr _ <- P.head `liftM` getAddrInfo Nothing (Just host) (Just port)+	return $ Just addr
src/Clanlist.hs view
@@ -1,9 +1,10 @@-module Clanlist where+module Clanlist (newClanList, newClanSync, newOnlineClans) where  import Graphics.UI.Gtk  import Control.Concurrent import Control.Concurrent.STM+import Control.Monad import qualified Data.ByteString.Char8 as B import Data.Ord import Data.Tree@@ -25,8 +26,8 @@ import TremFormatting  -newClanList :: Bundle -> IO (VBox, IO ())-newClanList Bundle{..} = do+newClanList :: Bundle -> [Clan] -> SetCurrent -> IO (VBox, ClanPolledHook, Entry)+newClanList Bundle{..} cache setCurrent = do 	raw			<- listStoreNew [] 	filtered		<- treeModelFilterNew raw [] 	sorted			<- treeModelSortNewWithModel filtered@@ -35,10 +36,12 @@  	(infobox, statNow, statTot) <- newInfobox "clans" -	(filterbar, current)	<- newFilterBar filtered statNow ""+	(filterbar, current, ent)	<- newFilterBar filtered statNow "" -	let updateF = do-		new <- atomically $ readTMVar mclans+	let updateF newraw P.PollResult{..} = do+		let new = (`map` newraw) $ \c -> case clanserver c of+			Nothing -> (c, False)+			Just a -> (c, a `elemByAddress` polled) 		listStoreClear raw 		treeViewColumnsAutosize view 		mapM_ (listStoreAppend raw) new@@ -47,38 +50,63 @@ 		n <- treeModelIterNChildren filtered Nothing 		set statNow [ labelText := show n ] -	addColumnsFilterSort raw filtered sorted view (Just (comparing name)) [-		  ("_Name"	, 0 , False	, True	, False	, unpackorig . name	, Just (comparing name))-		, ("_Tag"	, 0 , False	, True	, False	, unpackorig . tag	, Just (comparing tag))-		, ("Website"	, 0 , False	, True	, False	, B.unpack . showURL . website	, Nothing)-		, ("IRC"	, 0 , False	, True	, False	, B.unpack . irc	, Nothing)+	addColumnsFilterSort raw filtered sorted view 1 SortAscending +		[ (""		, False	, RendPixbuf haveServer+			, Just (comparing (isJust . clanserver . fst)))+		, ("_Name"	, False	, RendText (simpleColumn (unpackorig . name))+			, Just (comparing (name . fst)))+		, ("_Tag"	, False	, RendText (markupColumn (prettyTagExpr . tagexpr))+			, Just (comparing (tagexpr . fst)))+		, ("Website"	, False	, RendText (simpleColumn (B.unpack . showURL . website))+			, Nothing)+		, ("IRC"	, False , RendText (simpleColumn (B.unpack . irc))+			, Nothing) 		]  	treeModelFilterSetVisibleFunc filtered $ \iter -> do-		Clan{..}	<- treeModelGetRow raw iter+		(Clan{..}, _)	<- treeModelGetRow raw iter 		s		<- readIORef current-		let cmplist	= [ cleanedCase name, cleanedCase tag ]+		let cmplist	= [ cleanedCase name, tagExprGet tagexpr ] 		return $ B.null s || smartFilter s cmplist -	box <- vBoxNew False 0+	on view cursorChanged $ do+		(path, _)		<- treeViewGetCursor view+		(Clan{..}, active)	<- getElementFS raw sorted filtered path+		+		when active $ whenJust clanserver $ \server -> do+			P.PollResult{..} <- atomically $ readTMVar mpolled+			whenJust (serverByAddress server polled) (setCurrent False) +	on view rowActivated $ \path _ -> do+		(Clan{..}, _) <- getElementFS raw sorted filtered path+		unless (B.null website) $+			openInBrowser (B.unpack website)++	box <- vBoxNew False 0 	boxPackStart box filterbar PackNatural spacing 	boxPackStart box scrollview PackGrow 0 	boxPackStart box infobox PackNatural 0 -	updateF+	+	updateF cache =<< atomically (readTMVar mpolled) -	return (box, updateF)-	where showURL x = fromMaybe x (stripPrefix "http://" x)+	return (box, updateF, ent)+	where+	showURL x = fromMaybe x (stripPrefix "http://" x)+	markupColumn f (item, _) = [ cellTextMarkup := Just (f item) ]+	simpleColumn f (item, _) = [ cellText := f item ]+	haveServer (Clan{..}, active) = case clanserver of+		Just _	-> [cellPixbufStockId := stockNetwork, cellSensitive := active]+		Nothing	-> [cellPixbufStockId := ""]  -newOnlineClans :: Bundle-> (Bool -> P.GameServer -> IO ()) -> IO (ScrolledWindow, IO ())+newOnlineClans :: Bundle-> SetCurrent -> IO (ScrolledWindow, ClanPolledHook) newOnlineClans Bundle{..} setServer = do 	Config {colors} <- atomically $ readTMVar mconfig  	let showName c =  case c of 		Left Clan{..}		-> "<b>" ++ htmlEscape (unpackorig name) ++ "</b>"-		Right (P.Player{..}, _)	-> pangoPretty colors name+		Right (name, _)		-> pangoPretty colors name  	let showServer c =  case c of 		Left _ -> ""@@ -87,58 +115,49 @@ 	raw	<- treeStoreNew [] 	view	<- treeViewNewWithModel raw - 	treeViewExpandAll view 	addColumns raw view [ 		  ("Name"	, 0	, True	, True	, True	, showName ) 		, ("Server"	, 0	, True	, True	, True	, showServer ) 		] -	let updateF = do-		P.PollResult{..}	<- atomically $ readTMVar mpolled-		clans			<- atomically $ readTMVar mclans+	let updateF clans P.PollResult{..} = do 		let players = buildTree $ sortByPlayers $-			associatePlayerToClans (makePlayerList polled) clans+			associatePlayerToClans (makePlayerNameList polled) clans 		treeStoreClear raw 		treeViewColumnsAutosize view 		mapM_ (treeStoreInsertTree raw [] 0) players 		treeViewExpandAll view -	onCursorChanged view $ do-		(x, _)		<- treeViewGetCursor view-		Just iter	<- treeModelGetIter raw x-		item		<- treeModelGetRow raw iter+	on view cursorChanged $ do+		(path, _)	<- treeViewGetCursor view+		item		<- getElement raw path 		case item of 			Left _ -> return () 			Right (_, a) -> setServer False a -	onRowActivated view $ \path _ -> do-		Just vIter	<- treeModelGetIter raw path-		gs	<- treeModelGetRow raw vIter+	on view rowActivated $ \path _ -> do+		gs		<- getElement raw path 		case gs of 			Left _ -> return () 			Right (_, gameserver) -> setServer True gameserver  	scroll <- scrollIt view PolicyAutomatic PolicyAutomatic - 	return (scroll, updateF)  --- -- /// Utility functions /////////////////////////////////////////////////////////////////////////// -type PlayerList = [(P.Player, P.GameServer)]+type PlayerList = [(TI, P.GameServer)] -type OnlineView = Forest (Either Clan (P.Player, P.GameServer))+type OnlineView = Forest (Either Clan (TI, P.GameServer))  associatePlayerToClans :: PlayerList -> [Clan] -> [(Clan, PlayerList)] associatePlayerToClans players clans = map f clans 	where 	f c@Clan{tagexpr} = (c, filter (cmp tagexpr) players)-	cmp e = matchTagExpr e . P.name . fst+	cmp e = matchTagExpr e . fst  buildTree :: [(Clan, PlayerList)] -> OnlineView buildTree = filter notEmpty . foldr f [] where@@ -146,40 +165,26 @@ 	rightNode x = Node (Right x) [] 	notEmpty (Node _ [])	= False 	notEmpty _		= True---f tag x = -sortByPlayers :: [(a, [b])] -> [(a, [b])]-sortByPlayers = sortBy (comparing (length . snd))--newClanSync :: Bundle -> IO () -> IO (HBox, IO ())-newClanSync Bundle{..} updateF = do-	button	<- buttonNewWithMnemonic "_Sync clan list"-	img	<- imageNewFromStock stockSave IconSizeButton-	set button 	[ buttonImage := img-			, buttonRelief := ReliefNone-			, buttonFocusOnClick := False ]--	box	<- hBoxNew False 0-	boxPackStart box button PackRepel 0-+sortByPlayers :: [(Clan, [b])] -> [(Clan, [b])]+sortByPlayers = sortBy (flip (comparing (\(a, b) -> (-length b, name a)))) -	let doSync = do-		set button [ widgetSensitive := False ]-		Config {clanSyncURL} <- atomically $ readTMVar mconfig-		forkIO $ do-			new <- getClanList clanSyncURL-			case new of-				Nothing	-> postGUISync $ do-					gtkError "Unable to download clanlist"+newClanSync :: Bundle -> Button -> [ClanHook] -> [ClanPolledHook] -> IO ()+newClanSync Bundle{..} button clanHook bothHook = do+	set button [ widgetSensitive := False ]+	Config {clanSyncURL} <- atomically $ readTMVar mconfig+	forkIO $ do+		new <- getClanList clanSyncURL+		case new of+			Nothing	-> postGUISync $ do+				gtkError "Unable to download clanlist"+				set button [ widgetSensitive := True ]+			Just a	-> do+				result <- atomically $ do+					swapTMVar mclans a+					readTMVar mpolled+				postGUISync $ do+					mapM_ ($ a) clanHook+					mapM_ (\f -> f a result) bothHook 					set button [ widgetSensitive := True ]-				Just a	-> do-					atomically $-						swapTMVar mclans a-					postGUISync $ do-						updateF-						set button [ widgetSensitive := True ]-		return ()--	on button buttonActivated doSync--	return (box, doSync)+	return ()
src/Config.hs view
@@ -42,7 +42,7 @@ 	, filterEmpty	= True 	, delays	= defaultDelay 	, colors	= makeColorsFromList $-		TFNone : map TFColor ["#d60503", "#25c200", "#eab93d", "#0021fe", "#04c9c9", "#e700d7"] ++ [TFNone]+		TFNone "#000000" : map TFColor ["#d60503", "#25c200", "#eab93d", "#0021fe", "#04c9c9", "#e700d7"] ++ [TFNone "#000000"] 	}  makeColorsFromList :: [e] -> Array Int e makeColorsFromList = listArray (0,7)
src/Constants.hs view
@@ -5,6 +5,8 @@ import System.FilePath import System.Directory import System.IO+import System.Process+import Control.Exception  #ifdef CABAL_PATH import Paths_apelsin@@ -35,18 +37,36 @@ getDataDir = getCurrentDirectory #endif ++defaultTremulousPath, defaultTremulousGPPPath:: FilePath trace :: String -> IO ()-defaultTremulousPath, defaultTremulousGPPPath :: FilePath+defaultBrowser :: String -> IO CreateProcess #if defined(mingw32_HOST_OS) || defined(__MINGW32__) defaultTremulousPath	= "C:\\Program Files\\Tremulous\\tremulous.exe" defaultTremulousGPPPath	= "C:\\Program Files\\Tremulous\\tremulous-gpp.exe" trace _			= return ()+defaultBrowser x	= do+	ddir <- getDataDir+	return (proc "wscript" [ddir </> "open.js", x]) #else defaultTremulousPath	= "tremulous" defaultTremulousGPPPath	= "tremulous-gpp"-trace 			= hPutStrLn stderr+trace x			= hPutStrLn stderr x >> hFlush stderr++#if defined(__APPLE__) || defined(__MACH__)+defaultBrowser	x	= return $ proc "open" [x]+#else+defaultBrowser	x	= return $ proc "xdg-open" [x] #endif +#endif++openInBrowser :: String -> IO ()+openInBrowser x = handle (\(_ :: IOError) -> return ()) $ do+	p <-defaultBrowser x+	createProcess p+		{close_fds = True, std_in = Inherit, std_out = Inherit, std_err = Inherit}+	return ()  spacing, spacingHalf, spacingBig :: Integral i => i spacing		= 4
src/FilterBar.hs view
@@ -5,28 +5,29 @@ import qualified Data.ByteString.Char8 as B import Data.ByteString.Char8 (ByteString) import Data.Char+import Control.Monad.IO.Class import Network.Tremulous.ByteStringUtils as B +import GtkExts import Constants   newFilterBar :: (TreeModelClass self, TreeModelFilterClass self) => self -> Label -> String-	-> IO (HBox, IORef ByteString)+	-> IO (HBox, IORef ByteString, Entry) newFilterBar filtered stat initial  = do 	current <- newIORef "" 	 	-- Filterbar 	ent <- entryNew-	set ent [ widgetHasFocus	:= True-		, widgetIsFocus		:= True-		, widgetCanDefault	:= True-		, entryText		:= initial ]-	lbl <- labelNewWithMnemonic "_Filter:"-	set lbl [ labelMnemonicWidget := ent ]+	set ent [ entryText := initial ]+	entrySetIconFromStock ent EntryIconSecondary stockClear+		+	lbl <- labelNew (Just "Filter:")+	set lbl [ widgetTooltipText := Just "Ctrl+L or Ctrl+F" ] 	-	findbar <- hBoxNew False spacing-	boxPackStart findbar lbl PackNatural 0-	boxPackStart findbar ent PackGrow 0+	findbar <- hBoxNew False 0+	boxPackStart findbar lbl PackNatural spacingHalf+	boxPackStart findbar ent PackGrow spacingHalf 	 	let f = do 		rawstr <- entryGetText ent@@ -35,11 +36,13 @@ 		treeModelFilterRefilter filtered 		n <- treeModelIterNChildren filtered Nothing 		set stat [ labelText := show n ]-		return True 	f -	onKeyRelease ent (const f) -		-	return (findbar, current)+	on ent editableChanged f++	on ent entryIconPress $+		const $ liftIO $editableDeleteText ent 0 (-1)+	+	return (findbar, current, ent)  	 data Expr = Is !ByteString | Not !ByteString
src/FindPlayers.hs view
@@ -2,6 +2,7 @@ import Graphics.UI.Gtk  import Data.IORef+import Data.Ord import qualified Data.ByteString.Char8 as B import Network.Tremulous.Protocol import Network.Tremulous.Util@@ -14,50 +15,48 @@ import Constants import Config -newFindPlayers :: Bundle -> (Bool -> GameServer -> IO ()) -> IO (VBox, IO ())+newFindPlayers :: Bundle -> SetCurrent -> IO (VBox, PolledHook, Entry) newFindPlayers Bundle{..} setServer = do-	Config {colors} <- atomically $ readTMVar mconfig-	rawmodel	<- listStoreNew []-	model		<- treeModelFilterNew rawmodel []-	view		<- treeViewNewWithModel model+	Config {..}	<- atomically $ readTMVar mconfig+	raw		<- listStoreNew []+	filtered	<- treeModelFilterNew raw []+	sorted		<- treeModelSortNewWithModel filtered	+	view		<- treeViewNewWithModel sorted 	-	addColumnsFilter rawmodel model view [-		  ("Name", True, pangoPretty colors . fst)-		, ("Server", True, pangoPretty colors . hostname . snd) +	addColumnsFilterSort raw filtered sorted view 0 SortAscending+		[ ("Name"	, True	, RendText (simpleColumn colors fst)+			, Just (comparing fst))+		, ("Server"	, True	, RendText (simpleColumn colors (hostname . snd))+			, Just (comparing (address .snd)))  		] -	(infobox, statNow, statTot) <- newInfobox "players"-	Config {filterPlayers} <- atomically $ readTMVar mconfig-	(filterbar, current)	<- newFilterBar model statNow filterPlayers+	(infobox, statNow, statTot)	<- newInfobox "players"+	(filterbar, current, ent)	<- newFilterBar filtered statNow filterPlayers 	-	treeModelFilterSetVisibleFunc model $ \iter -> do-		(item,_) <- treeModelGetRow rawmodel iter+	treeModelFilterSetVisibleFunc filtered $ \iter -> do+		(item, GameServer{..}) <- treeModelGetRow raw iter 		s <- readIORef current-		return $ B.null s || s `B.isInfixOf` cleanedCase item+		return $ B.null s || smartFilter s [+				  cleanedCase item+				, proto2string protocol+				, maybe "" cleanedCase gamemod+				] 		-	let updateFilter = do-		PollResult{..} <- atomically $ readTMVar mpolled-		listStoreClear rawmodel+	let updateFilter PollResult{..} = do+		listStoreClear raw 		let plist = makePlayerNameList polled-		mapM_ (listStoreAppend rawmodel) plist-		treeModelFilterRefilter model+		mapM_ (listStoreAppend raw) plist+		treeModelFilterRefilter filtered 		set statTot [ labelText := show (length plist) ]-		n <- treeModelIterNChildren model Nothing+		n <- treeModelIterNChildren filtered Nothing 		set statNow [ labelText := show n ] 						-	onCursorChanged view $ do-		(x, _) <- treeViewGetCursor view-		Just vIter <- treeModelGetIter model x-		iter	<-treeModelFilterConvertIterToChildIter model vIter-		gameserver <- treeModelGetRow rawmodel iter-		setServer False (snd gameserver)-		return ()+	on view cursorChanged $ do+		(path, _) <- treeViewGetCursor view+		setServer False . snd =<< getElementFS raw sorted filtered path -	onRowActivated view $ \path _ -> do-		Just vIter	<- treeModelGetIter model path-		fIter		<- treeModelFilterConvertIterToChildIter model vIter-		gameserver	<- treeModelGetRow rawmodel fIter-		setServer True (snd gameserver)+	on view rowActivated $ \path _ -> do+		setServer True . snd =<< getElementFS raw sorted filtered path 	 	scroll <- scrollIt view PolicyAutomatic PolicyAlways 	@@ -66,4 +65,7 @@ 	boxPackStart box scroll PackGrow 0 	boxPackStart box infobox PackNatural 0 	-	return (box, updateFilter)+	return (box, updateFilter, ent)+	where simpleColumn colors f item =+		[ cellTextEllipsize := EllipsizeEnd+		, cellTextMarkup := Just (pangoPretty colors (f item)) ]
+ src/GtkExts.hs view
@@ -0,0 +1,24 @@+module GtkExts (+	EntryIconPosition(..)+	, entrySetIconFromStock+) where+import System.Glib.FFI+import System.Glib.UTFString+import Graphics.UI.GtkInternals+import Graphics.UI.Gtk.General.StockItems+import Graphics.UI.Gtk.General.Enums++entrySetIconFromStock	:: EntryClass self => self+			-> EntryIconPosition+			-> StockId+			-> IO ()+entrySetIconFromStock entry iconPos stockId =+	(\(Entry arg1) arg2 ->+		withForeignPtr arg1 $ \argPtr1 ->+		withUTFString stockId $ \stockIdPtr ->+		gtk_entry_set_icon_from_stock argPtr1 arg2 stockIdPtr)+			(toEntry entry)+			((fromIntegral . fromEnum) iconPos)++foreign import ccall safe "gtk_entry_set_icon_from_stock"+	gtk_entry_set_icon_from_stock :: Ptr Entry -> CInt -> Ptr CChar -> IO ()
src/GtkUtils.hs view
@@ -19,9 +19,9 @@ 	scroll <- scrolledWindowNew Nothing Nothing 	scrolledWindowSetPolicy scroll pol1 pol2 	scrolledWindowAddWithViewport scroll widget-	--set scroll [ scrolledWindowShadowType := ShadowNone ] 	Just vp <- binGetChild scroll-	set (castToViewport vp) [ viewportShadowType  := ShadowNone ]+	set scroll [ scrolledWindowShadowType := ShadowNone ]+	set (castToViewport vp) [ viewportShadowType := ShadowNone ] 	return scroll 	 @@ -43,14 +43,6 @@ 	frameSetLabel frame lbl 	return frame 	-	-notebookAppendMnemonic :: (NotebookClass self, WidgetClass child) => self -> child -> String -> IO Int-notebookAppendMnemonic nb child txt = do-	n <- notebookAppendPage nb child ""-	lbl <- labelNewWithMnemonic txt-	notebookSetTabLabel nb child lbl-	return n- addColumns :: (TreeViewClass view, TreeModelClass (model row), TypedTreeModelClass model) => 	model row -> view -> [(String, Float, Bool, Bool, Bool, row -> String)] -> IO () addColumns model view xs = mapM_ g xs where@@ -106,28 +98,34 @@ 			set rend [ cellTextMarkup := Just (showf item) ] 		treeViewAppendColumn view col +data RendType i = RendText (i -> [AttrOp CellRendererText]) | RendPixbuf (i -> [AttrOp CellRendererPixbuf]) addColumnsFilterSort :: (TreeViewClass self, TreeSortableClass self1, TreeModelSortClass self1, 	TreeModelFilterClass self2, TreeModelClass self1, TypedTreeModelClass model) =>-	model t -> self2 -> self1 -> self -> Maybe (t -> t -> Ordering)-	-> [(String, Float, Bool, Bool, Bool, t -> String, Maybe (t -> t -> Ordering))]+	model t -> self2 -> self1 -> self -> Int -> SortType+	-> [(String, Bool, RendType t, Maybe (t -> t -> Ordering))] 	-> IO ()-addColumnsFilterSort raw filtered sorted view defaultSort xs = zipWithM_ f [0..] xs where-	f n (title, align, format, expand, ellipsize, showf,  sortf) = do+addColumnsFilterSort raw filtered sorted view defaultSort sortType xs = zipWithM_ f [0..] xs where+	f n (title, expand, rt, sortf) = do 		col <- treeViewColumnNew 		set col	[ treeViewColumnTitle := title 			, treeViewColumnExpand := expand ]-		rend <- cellRendererTextNew-		when ellipsize $-			set rend [ cellTextEllipsizeSet := True, cellTextEllipsize := EllipsizeEnd]-		set rend [ cellXAlign := align]-		cellLayoutPackStart col rend True-		cellLayoutSetAttributeFunc col rend sorted $ \iter -> do-			cIter	<- treeModelSortConvertIterToChildIter sorted iter-			rcIter	<- treeModelFilterConvertIterToChildIter filtered cIter-			item	<- treeModelGetRow raw rcIter-			set rend $ if format -				then [ cellTextMarkup := Just (showf item) ]-				else [ cellText := showf item ] +		case rt of+			RendText attr -> do+				rend <- cellRendererTextNew+				cellLayoutPackStart col rend True+				cellLayoutSetAttributeFunc col rend sorted $ \iter -> do+					cIter	<- treeModelSortConvertIterToChildIter sorted iter+					rcIter	<- treeModelFilterConvertIterToChildIter filtered cIter+					item	<- treeModelGetRow raw rcIter+					set rend $ attr item+			RendPixbuf attr -> do+				rend <- cellRendererPixbufNew+				cellLayoutPackStart col rend True+				cellLayoutSetAttributeFunc col rend sorted $ \iter -> do+					cIter	<- treeModelSortConvertIterToChildIter sorted iter+					rcIter	<- treeModelFilterConvertIterToChildIter filtered cIter+					item	<- treeModelGetRow raw rcIter+					set rend $ attr item 		treeViewAppendColumn view col 		case sortf of 			Nothing	-> return ()@@ -137,11 +135,29 @@ 					rit1	<- treeModelFilterConvertIterToChildIter filtered it1 					rit2	<- treeModelFilterConvertIterToChildIter filtered it2 					xort raw g rit1 rit2-		whenJust defaultSort $ \a -> treeSortableSetDefaultSortFunc sorted $ Just $ \it1 it2 -> do-				rit1	<- treeModelFilterConvertIterToChildIter filtered it1-				rit2	<- treeModelFilterConvertIterToChildIter filtered it2-				xort raw a rit1 rit2-				+		treeSortableSetDefaultSortFunc sorted Nothing+		treeSortableSetSortColumnId sorted defaultSort sortType+		+getElementFS :: (TreeModelClass self, TreeModelFilterClass self1, TreeModelSortClass self, TypedTreeModelClass model) =>+	model b -> self -> self1 -> TreePath -> IO b+getElementFS store sorted filtered x = do+	Just vIter	<- treeModelGetIter sorted x+	sIter		<- treeModelSortConvertIterToChildIter sorted vIter+	fIter		<- treeModelFilterConvertIterToChildIter filtered sIter+	treeModelGetRow store fIter++getElementF :: (TreeModelClass self, TreeModelFilterClass self, TypedTreeModelClass model) =>+	model b -> self -> TreePath -> IO b+getElementF store filtered path = do+	Just vIter	<- treeModelGetIter filtered path+	iter		<- treeModelFilterConvertIterToChildIter filtered vIter+	treeModelGetRow store iter+	+getElement :: (TreeModelClass (model m), TypedTreeModelClass model) => model m -> TreePath -> IO m+getElement raw path = do+	Just iter	<- treeModelGetIter raw path+	treeModelGetRow raw iter+		 gtkPopup :: MessageType -> String -> IO () gtkPopup what str = do 	a <- messageDialogNew Nothing [DialogDestroyWithParent, DialogModal]
src/List2.hs view
@@ -1,4 +1,4 @@-module List2 (stripw, intmean) where+module List2 (stripw, intmean, replace) where import Prelude hiding (foldr, foldl, foldr1, foldl1) import Data.Char import Data.Foldable@@ -12,3 +12,9 @@ intmean :: (Integral i, Foldable f) => f i -> i intmean l = if len == 0 then 0 else lsum `div` len where 	(len, lsum) = foldl' (\(!n, !s) elm -> (n+1, s+elm)) (0, 0) l++replace :: (a -> Bool) -> a -> [a] -> [a]+replace f y (x:xs)+	| f x		= y : xs+	| otherwise	= x : replace f y xs+replace _ _ []		= []
src/Preferences.hs view
@@ -7,6 +7,7 @@ import Data.Array import Text.Printf import Network.Tremulous.Protocol+import System.FilePath  import Types import Config@@ -18,22 +19,19 @@ newPreferences :: Bundle -> IO ScrolledWindow newPreferences Bundle{..} = do 	-- Default filters-	 	(tbl, [filterBrowser', filterPlayers'], filterEmpty') <- 		configTable ["_Browser:", "Find _players:"] 	filters <- newLabeledFrame "Default filters" 	set filters [ containerChild := tbl] - 	-- Tremulous path 	(pathstbl, [tremPath', tremGppPath']) <- pathTable parent ["_Tremulous 1.1:", "Tremulous _GPP:"] 	paths <- newLabeledFrame "Tremulous path or command" 	set paths [ containerChild := pathstbl]  	-- Startup--	startupMaster	<- checkButtonNewWithMnemonic "Re_fresh all servers"-	startupClan	<- checkButtonNewWithMnemonic "S_ync clan list"+	startupMaster	<- checkButtonNewWithMnemonic "_Refresh all servers"+	startupClan	<- checkButtonNewWithMnemonic "_Sync clan list" 	startupGeometry	<- checkButtonNewWithMnemonic "Restore _window geometry from previous session" 	 	(startup, startupBox) <- framedVBox ("On startup")@@ -64,7 +62,6 @@   	-- Apply-	 	apply	<- buttonNewFromStock stockApply 	bbox	<- hBoxNew False 0 	boxPackStartDefaults bbox apply@@ -86,10 +83,8 @@ 		 		rawcolors	<- forM colorList $ \(colb, cb) -> do 					bool <- get cb toggleButtonActive-					if bool then-						TFColor . colorToHex <$> colorButtonGetColor colb-					else-						return TFNone+					(if bool then TFColor else TFNone)+						 . colorToHex <$> colorButtonGetColor colb 		old		<- atomically $ takeTMVar mconfig 		let new		= old {filterBrowser, filterPlayers, autoMaster 				, autoClan, autoGeometry, tremPath, tremGppPath@@ -129,7 +124,8 @@ 		where	f (a, b) (TFColor c) = do 				colorButtonSetColor a (hexToColor c) 				toggleButtonSetActive b True-			f (_,b) _ = do+			f (a ,b) (TFNone c) = do+				colorButtonSetColor a (hexToColor c) 				toggleButtonSetActive b False 				-- Apparently this is needed too 				toggleButtonToggled b@@ -176,16 +172,14 @@ mkInternals :: IO (Table, [SpinButton]) mkInternals = do 	tbl <- tableNew 0 0 False-	tips <- tooltipsNew- 	let easyAttach pos (lbl, lblafter, tip)  = do 		a <- labelNewWithMnemonic lbl-		tooltipsSetTip tips a tip "" 		b <- spinButtonNewWithRange 0 10000 1 		c <- labelNew (Just lblafter)-		set a [ labelMnemonicWidget := b ]-		miscSetAlignment a 0 0.5-		miscSetAlignment c 0 0+		set a	[ labelMnemonicWidget := b+			, widgetTooltipText := Just tip+			, miscXalign := 0 ]+		set c	[ miscXalign := 0 ] 		tableAttach tbl a 0 1 pos (pos+1) [Fill] [] spacing spacingHalf 		tableAttach tbl b 1 2 pos (pos+1) [Fill] [] spacing spacingHalf 		tableAttach tbl c 2 3 pos (pos+1) [Fill] [] spacing spacingHalf@@ -244,6 +238,8 @@ 		fc	<- fileChooserDialogNew (Just "Select path") (Just parent) FileChooserActionOpen 			[ (stockCancel, ResponseCancel) 			, (stockOpen, ResponseAccept) ]+		current <- takeDirectory <$> get ent entryText+		fileChooserSetCurrentFolder fc current 		widgetShow fc 		resp <- dialogRun fc 		case resp of
src/STM2.hs view
@@ -1,6 +1,6 @@ module STM2( 	module Control.Concurrent, module Control.Concurrent.STM-	, tryReadTMVar, withTMVar, clearTMVar, replaceTMVar+	, tryReadTMVar, withTMVar, clearTMVar, replaceTMVar, modifyTMVar ) where  import Control.Concurrent@@ -30,3 +30,8 @@  replaceTMVar :: TMVar a -> a -> STM () replaceTMVar t x = clearTMVar t >> putTMVar t x++modifyTMVar :: TMVar a -> (a -> a) -> STM ()+modifyTMVar x f = do+	t <- takeTMVar x+	putTMVar x (f t)
src/ServerBrowser.hs view
@@ -15,29 +15,31 @@ import Constants import Config -newServerBrowser :: Bundle -> (Bool -> GameServer -> IO ()) -> IO (VBox, IO ())-newServerBrowser Bundle{..} setServer = do-	Config {colors} <- atomically $ readTMVar mconfig-	rawmodel	<- listStoreNew []-	filtered	<- treeModelFilterNew rawmodel []-	model		<- treeModelSortNewWithModel filtered	-	view		<- treeViewNewWithModel model+newServerBrowser :: Bundle -> SetCurrent -> IO (VBox, PolledHook,Entry)+newServerBrowser Bundle{browserStore=raw, ..} setServer = do+	Config {..}	<- atomically $ readTMVar mconfig+	filtered	<- treeModelFilterNew raw []+	sorted		<- treeModelSortNewWithModel filtered	+	view		<- treeViewNewWithModel sorted 	-	addColumnsFilterSort rawmodel filtered model view (Just (comparing gameping)) [-		  ("_Game"	, 0	, False	, False	, False	, showGame , Just (comparing (\x -> (protocol x, gamemod x))))-		, ("_Name"	, 0	, True	, True	, True	, pangoPretty colors . hostname	, Just (comparing hostname))-		, ("_Map"	, 0	, True	, False	, False	, take 16 . unpackorig . mapname	, Just (comparing mapname))-		, ("P_ing"	, 1	, False	, False , False	, show . gameping	, Just (comparing gameping))-		, ("_Players"	, 1	, False	, False , False	, showPlayers		, Just (comparing nplayers))+	addColumnsFilterSort raw filtered sorted view 3 SortAscending+		[ ("_Game"	, False	, RendText (simpleColumn showGame)+		   	, Just (comparing (\x -> (protocol x, gamemod x))))+		, ("_Name"	, True	, RendText (markupColumn colors hostname)+			, Just (comparing hostname))+		, ("_Map"	, False	, RendText (simpleColumn (take 16 . unpackorig . mapname))+			, Just (comparing mapname))+		, ("P_ing"	, False	, RendText (intColumn (show . gameping))+			, Just (comparing gameping))+		, ("_Players"	, False	, RendText (intColumn (showPlayers))+			, Just (comparing nplayers)) 		]- 	(infobox, statNow, statTot, statRequested) <- newInfoboxBrowser 	-	Config {filterBrowser, filterEmpty} <- atomically $ readTMVar mconfig-	(filterbar, current) <- newFilterBar filtered statNow filterBrowser+	(filterbar, current, ent) <- newFilterBar filtered statNow filterBrowser 	empty <- checkButtonNewWithMnemonic "_empty" 	set empty [ toggleButtonActive := filterEmpty ]-	boxPackStart filterbar empty PackNatural 0+	boxPackStart filterbar empty PackNatural spacingHalf 	on empty toggled $ do 		treeModelFilterRefilter filtered 		n <- treeModelIterNChildren filtered Nothing@@ -45,7 +47,7 @@   	treeModelFilterSetVisibleFunc filtered $ \iter -> do-		GameServer{..}	<- treeModelGetRow rawmodel iter+		GameServer{..}	<- treeModelGetRow raw iter 		s		<- readIORef current 		showEmpty	<- toggleButtonGetActive empty 		return $ (showEmpty || not (null players)) && (B.null s ||@@ -56,43 +58,38 @@ 				, maybe "" cleanedCase gamemod 				]) 			-	onCursorChanged view $ do-		(x, _)		<- treeViewGetCursor view-		Just vIter	<- treeModelGetIter model x-		sIter		<- treeModelSortConvertIterToChildIter model vIter-		fIter		<- treeModelFilterConvertIterToChildIter filtered sIter-		gameserver	<- treeModelGetRow rawmodel fIter-		setServer False gameserver+	on view cursorChanged $ do+		(path, _) <- treeViewGetCursor view+		setServer False =<< getElementFS raw sorted filtered path -	onRowActivated view $ \path _ -> do-		Just vIter	<- treeModelGetIter model path-		sIter		<- treeModelSortConvertIterToChildIter model vIter-		fIter		<- treeModelFilterConvertIterToChildIter filtered sIter-		gameserver	<- treeModelGetRow rawmodel fIter-		setServer True gameserver+	on view rowActivated $ \path _ ->+		setServer True =<< getElementFS raw sorted filtered path 		-	 	scrollview <- scrolledWindowNew Nothing Nothing 	scrolledWindowSetPolicy scrollview PolicyNever PolicyAlways 	containerAdd scrollview view 	-	let updateF = do-		PollResult{..} <- atomically $ readTMVar mpolled-		listStoreClear rawmodel+	let updateF PollResult{..} = do+		listStoreClear raw 		treeViewColumnsAutosize view-		mapM_ (listStoreAppend rawmodel) polled+		mapM_ (listStoreAppend raw) polled 		treeModelFilterRefilter filtered 		set statTot		[ labelText := show serversResponded ] 		set statRequested	[ labelText := show (serversRequested-serversResponded) ] 		n <- treeModelIterNChildren filtered Nothing-		set statNow [ labelText := show n ]+		set statNow 		[ labelText := show n ] 		 	box <- vBoxNew False 0 	boxPackStart box filterbar PackNatural spacing 	boxPackStart box scrollview PackGrow 0 	boxPackStart box infobox PackNatural 0 	-	return (box, updateF)+	return (box, updateF, ent) 	where 	showGame GameServer{..} = proto2string protocol ++ maybe "" (("-"++) . htmlEscape . unpackorig) gamemod 	showPlayers GameServer{..} = printf "%d / %2d" nplayers slots+	markupColumn colors f item =+		[ cellTextEllipsize := EllipsizeEnd+		, cellTextMarkup := Just (pangoPretty colors (f item)) ]+	intColumn f item = [ cellText := f item , cellXAlign := 1 ]+	simpleColumn f item = [ cellText := f item ]
src/ServerInfo.hs view
@@ -1,12 +1,14 @@-module ServerInfo where+module ServerInfo (newServerInfo) where import Graphics.UI.Gtk  import Prelude hiding (catch)+import Control.Applicative import Control.Monad hiding (join) import Control.Exception import Data.Ord-import Data.List (sortBy)+import Data.List (sortBy, findIndex) import System.Process+import System.FilePath  import Network.Tremulous.Protocol import Network.Tremulous.Polling@@ -20,74 +22,76 @@ import Constants import Config -newServerInfo :: Bundle -> IO (VBox, IO (), Bool -> GameServer -> IO ())-newServerInfo Bundle{..} = do+newServerInfo :: Bundle -> TMVar (PolledHook, ClanPolledHook) -> IO (VBox, PolledHook, SetCurrent)+newServerInfo Bundle{..} mupdate = do 	Config {colors} <- atomically $ readTMVar mconfig 	current		<- atomically newEmptyTMVar 	running		<- atomically newEmptyTMVar 	 	-- Host name 	hostnamex <- labelNew Nothing-	hostnamex `labelSetMarkup` "<b><big>Server</big></b>" 	set hostnamex [-		  labelWrap	:= True-		, labelJustify	:= JustifyCenter-		, labelSelectable := True+		  labelWrap		:= True+		, labelJustify		:= JustifyCenter+		, labelSelectable	:= True+		, labelUseMarkup	:= True+		, labelLabel		:= formatHostname "Server" 		-- failgtk exception.. 		--, labelWrapMode := WrapPartialWords 		] 	-	-- Pretty Cvar table+	-- Pretty CVar table 	tbl <- tableNew 5 2 True+	set tbl [ tableRowSpacing := spacing+		, tableColumnSpacing := spacingBig ] 	let easyAttach pos lbl  = do 		a <- labelNew (Just lbl) 		b <- labelNew Nothing-		miscSetAlignment a 1 0.5-		miscSetAlignment b 0 0.5-		tableAttach tbl a 0 1 pos (pos+1) [Expand, Fill] [Expand, Fill] 8 2-		tableAttach tbl b 1 2 pos (pos+1) [Expand, Fill] [Expand, Fill] 8 2 +		set a [ miscXalign := 1 ]+		set b [ miscXalign := 0 ]+		tableAttachDefaults tbl a 0 1 pos (pos+1)+		tableAttachDefaults tbl b 1 2 pos (pos+1) 		return b 		-	let mkTable xs = mapM (uncurry easyAttach) (zip [0..] xs)-	datta <- mkTable ["IP:Port", "Game (mod)", "Map", "Password protected"+	let mkTable = zipWithM easyAttach [0..]+	info <- mkTable ["IP:Port", "Game (mod)", "Map", "Timelimit (SD)" 			, "Slots (+private)", "Ping (server average)"]-	set (head datta) [ labelSelectable := True ]-	+	set (head info) [ labelSelectable := True ] 	 	-- Players-	allplayers <- vBoxNew False 4-	--allplayersscroll <- scrollItV allplayers PolicyNever PolicyAutomatic-		-	alienshumans <- hBoxNew True 4+	allplayers	<- vBoxNew False spacing+	alienshumans	<- hBoxNew True spacing 	-	let playerView x = simpleListView [(x, True, pangoPretty colors . name)-					, ("Score", False, show . kills)-					, ("Ping", False, show . ping)-					]+	let playerView x = simpleListView+		[ (x		, True	, pangoPretty colors . name)+		, ("Score"	, False	, show . kills)+		, ("Ping"	, False	, show . ping) ] 	(amodel, aview) <- playerView "Aliens" 	(hmodel, hview) <- playerView "Humans" 	(smodel, sview) <- simpleListView [("Spectators", True, pangoPretty colors . name) 					, ("Ping", False, show . ping)]+	-- For servers not giving the P CVar+	(umodel, uview) <- playerView "Players" 	+	 	ascroll <- scrollIt aview PolicyNever PolicyAutomatic 	hscroll <- scrollIt hview PolicyNever PolicyAutomatic+	uscroll	<- scrollIt uview PolicyNever PolicyAutomatic+	sscroll <- scrollIt sview PolicyNever PolicyAutomatic+	set uscroll [ widgetNoShowAll := True ] 	boxPackStart alienshumans ascroll PackGrow 0 	boxPackStart alienshumans hscroll PackGrow 0   	boxPackStart allplayers alienshumans PackGrow 0-	specscroll <- scrollIt sview PolicyNever PolicyAutomatic-	boxPackStart allplayers specscroll PackNatural 0+	boxPackStart allplayers sscroll PackNatural 0  	-- Action buttons-	 	join	<- buttonNewWithMnemonic "_Join Server" 	refresh	<- buttonNewWithMnemonic "Refresh _current"-	jimg	<- imageNewFromStock stockConnect IconSizeButton-	rimg	<- imageNewFromStock stockRefresh IconSizeButton-	set join 	[ buttonImage := jimg+	set join 	[ buttonImage :=> imageNewFromStock stockConnect IconSizeButton 			, widgetSensitive := False ]-	set refresh	[ buttonImage := rimg+	set refresh	[ buttonImage :=> imageNewFromStock stockRefresh IconSizeButton 			, widgetSensitive := False ] 	 	serverbuttons <- hBoxNew False 0@@ -100,22 +104,25 @@ 	boxPackStart rightpane hostnamex PackNatural 1 	boxPackStart rightpane tbl PackNatural 0 	boxPackStart rightpane allplayers PackGrow 0+	boxPackStart rightpane uscroll PackGrow 0 	boxPackStart rightpane serverbuttons PackNatural 2  -	let launchTremulous = withTMVar current $ \GameServer{..} -> do+	let launchTremulous = withTMVar current $ \gs -> do 		tst <- atomically $ tryTakeTMVar running-		whenJust tst $ \a -> catch (terminateProcess a) (\(_ :: IOError) -> return ())-		Config {tremPath, tremGppPath} <- atomically $ readTMVar mconfig-		let binary = case protocol of-			69 -> tremPath-			70 -> tremGppPath-			_  -> ""+		whenJust tst (ignoreIOException . terminateProcess)+		config <- atomically $ readTMVar mconfig  		set join [ widgetSensitive := False ]-		(_,_,_,p) <- createProcess $ (proc (stripw binary) ["+connect", show address])-			{close_fds = True, std_in = Inherit, std_out = Inherit, std_err = Inherit}-		atomically $ putTMVar running p++		pid <- maybeIO (runTremulous config gs)+		case pid of+			Nothing -> gtkError $ "Unable to run \"" ++ path ++ "\".\nHave you set your path correctly in Preferences?"+				where path = case protocol gs of+						70 -> tremGppPath config+						_  -> tremPath config+			Just a -> (atomically . putTMVar running) a+		 		forkIO $ do 			threadDelay 1000000 			postGUISync $ set join [ widgetSensitive := True ]@@ -123,35 +130,49 @@ 		return ()  	on join buttonActivated launchTremulous-		++	 	let setF boolJoin gs@GameServer{..} = do-		let (a:b:d:e:f:g:_) = datta-		hostnamex `labelSetMarkup` showHostname colors hostname-		a `labelSetMarkup` show address-		b `labelSetMarkup` (proto2string protocol ++ (case gamemod of+		zipWithM_ labelSetMarkup info+			[ show address+			, (proto2string protocol ++ (case gamemod of 					Nothing	-> "" 					Just z	-> " (" ++ unpackorig z ++ ")"))-		d `labelSetMarkup` unpackorig mapname-		e `labelSetMarkup` if protected then "Yes" else "No"-		f `labelSetMarkup` (show slots ++ " (+" ++ show privslots ++ ")")-		labelSetMarkup g $ show gameping ++ -			" (" ++ (show . intmean . filter validping . map ping) players ++ ")"+			, unpackorig mapname+			, maybeQ timelimit ++ " (" ++ maybeQ suddendeath ++ ")"+			, show slots ++ " (+" ++ show privslots ++ ")"+			, show gameping +++				" (" ++ (show . intmean . filter validping . map ping) players ++ ")"+			]+		hostnamex `labelSetMarkup` showHostname colors hostname 		 		listStoreClear amodel 		listStoreClear hmodel 		listStoreClear smodel+		listStoreClear umodel 		-		let (s', a', h', _) = partitionTeams (scoreSort players)-		mapM_ (listStoreAppend amodel) a'-		mapM_ (listStoreAppend hmodel) h'-		mapM_ (listStoreAppend smodel) s'-		treeViewColumnsAutosize aview-		treeViewColumnsAutosize hview-		treeViewColumnsAutosize sview-		Requisition _ sReq <- widgetSizeRequest sview-		set specscroll [ widgetHeightRequest := sReq ]+		let	sortedPlayers		= scoreSort players+			(s', a', h', u')	= partitionTeams sortedPlayers+		if null u' then do		+			mapM_ (listStoreAppend amodel) a'+			mapM_ (listStoreAppend hmodel) h'+			mapM_ (listStoreAppend smodel) s'+			treeViewColumnsAutosize aview+			treeViewColumnsAutosize hview+			treeViewColumnsAutosize sview+			Requisition _ sReq	<- widgetSizeRequest sview+			+			set sscroll [ widgetHeightRequest := min 300 sReq ]+			widgetShow allplayers				+			widgetHide uscroll	+		else do+			mapM_ (listStoreAppend umodel) sortedPlayers+			treeViewColumnsAutosize uview+			widgetShow uscroll+			widgetShow uview+			widgetHide allplayers 		-		atomically $ clearTMVar current >> putTMVar current gs+		atomically $ replaceTMVar current gs 		 		set join [ widgetSensitive := True ] 		set refresh [ widgetSensitive := True ]@@ -159,31 +180,71 @@ 		when boolJoin launchTremulous 		return () -		-	let updateF = withTMVar mpolled $ \PollResult{..} ->-		withTMVar current $ \GameServer{address} ->-			case serverByAddress address polled of-				Nothing -> return ()-				Just a	-> setF False a+	let updateF PollResult{..} = withTMVar current $ \GameServer{address} ->+			whenJust (serverByAddress address polled) (setF False) 			 	 	on refresh buttonActivated $ withTMVar current $ \x -> do 		set refresh [ widgetSensitive := False ] 		Config {delays} <- atomically $ readTMVar mconfig 		forkIO $ do-			new <- pollOne delays (address x)-			postGUISync $ do-				whenJust new (setF False)+			result <- pollOne delays (address x)+			+			whenJust result $ \new -> do+				pr <- atomically $ do+					pr@PollResult{polled} <- takeTMVar mpolled+					let pr' = pr +						{ polled = replace+							(\old -> address old == address new)+							new polled+						}+					putTMVar mpolled pr'+					return pr'+						+				mm <- findIndex (\old -> address old == address new) <$>+					listStoreToList browserStore+				(fa, fb)	<- atomically (readTMVar mupdate)+				clans		<- atomically (readTMVar mclans)+				postGUISync $ do+					fa pr+					fb clans pr+					setF False new+					-- This generates a gtk assertion fail. Howerver it+					-- seems innocent+					whenJust mm $ \i -> +						listStoreSetValue browserStore i new	+			postGUISync $ 				set refresh [ widgetSensitive := True ]+				 		return () 		 	return (rightpane, updateF, setF) 	where-	validping x = x > 0 && x < 999-	scoreSort = sortBy (flip (comparing kills))-	showHostname colors x = "<b><big>" ++-		(case pangoPretty colors x of-			"" -> "<i>Invalid name</i>"-			a -> a)-		++ "</big></b>"+	validping x		= x > 0 && x < 999+	scoreSort		= sortBy (flip (comparing kills))+	formatHostname x	= "<b><big>" ++ x ++ "</big></b>"+	showHostname colors x	= formatHostname $ case pangoPretty colors x of+					"" -> "<i>Invalid name</i>"+					a  -> a+	maybeQ			= maybe "?" show++runTremulous :: Config -> GameServer -> IO (Maybe ProcessHandle)+runTremulous Config{..} GameServer{..} = do+	(_,_,_,p) <- createProcess ((proc com args) {cwd = ldir})+		{close_fds = True, std_in = Inherit, std_out = Inherit, std_err = Inherit}+	maybe (Just p) (const Nothing) <$> getProcessExitCode p+	where+	(com, args) = case protocol of+		70 -> (tremGppPath, ["+connect", show address])+		_  -> (tremPath, ["-connect", show address, "+connect", show address]) 		+	ldir = case takeDirectory com of+		"" -> Nothing+		x  -> Just x+++ignoreIOException :: IO () -> IO ()+ignoreIOException = handle (\(_ :: IOError) -> return ())++maybeIO :: IO (Maybe a) -> IO (Maybe a)+maybeIO = handle (\(_ :: IOError) -> return Nothing)
src/Toolbar.hs view
@@ -5,12 +5,14 @@ import Control.Applicative import Control.Exception import Control.Monad+import Control.Monad.IO.Class import Data.Maybe+import Data.Char (toLower)  import Network.Socket  import Network.Tremulous.Protocol import Network.Tremulous.Polling-import Network.Tremulous.Scheduler (getMicroTime)+import Network.Tremulous.MicroTime  import Types import Constants@@ -21,7 +23,7 @@ import Clanlist  getDNS :: String -> String -> IO (Maybe SockAddr)-getDNS host port = handle (\(_::IOException) -> return Nothing) $ do+getDNS host port = handle (\(_ :: IOException) -> return Nothing) $ do 	AddrInfo _ _ _ _ addr _ <- Prelude.head `liftM` getAddrInfo Nothing (Just host) (Just port) 	return $ Just addr @@ -29,36 +31,29 @@ whileTrue :: Monad m => m Bool -> m () whileTrue f = f >>= \t -> when t (whileTrue f) -newToolbar :: Bundle -> IO () -> IO () -> IO HBox-newToolbar bundle@Bundle{..} clanHook polledHook = do	-	pbrbox		<- hBoxNew False spacing-		+newToolbar :: Bundle -> [ClanHook] -> [PolledHook] -> [ClanPolledHook] -> IO HBox+newToolbar bundle@Bundle{..} clanHook polledHook bothHook = do		 	pb		<- progressBarNew 	set pb		[ widgetNoShowAll := True ] 	-	refresh	<- buttonNewWithMnemonic "_Refresh all servers"-	rimg		<- imageNewFromStock stockRefresh IconSizeButton-	set refresh	[ buttonImage := rimg -			, buttonRelief := ReliefNone -			, buttonFocusOnClick := False ]-			-	about		<- buttonNewFromStock stockAbout-	set about	[ buttonRelief		:= ReliefNone -			, buttonFocusOnClick	:= False ]-+	refresh		<- mkToolButton "Refresh all servers" stockRefresh "Ctrl+R or F5"+	clansync	<- mkToolButton "Sync clan list" stockSave "Ctrl+S or F6"		+	about		<- mkToolButton "About" stockAbout "F7"+		+	let doSync = newClanSync bundle clansync clanHook bothHook+	 	on about buttonActivated $ newAbout parent+	on clansync buttonActivated $ doSync 			-	(clanSync, doSync) <- newClanSync bundle clanHook-	 	align		<- alignmentNew 0 0 0 0 	alignbox	<- hBoxNew False spacing 	set align [ containerChild := alignbox ] 	 	boxPackStartDefaults alignbox refresh-	boxPackStartDefaults alignbox clanSync+	boxPackStartDefaults alignbox clansync 	boxPackStartDefaults alignbox about 			-	+	pbrbox		<- hBoxNew False spacing 	set pbrbox [ containerBorderWidth := spacing ] 	boxPackStart pbrbox align PackNatural 0 	boxPackStart pbrbox pb PackGrow 0@@ -68,7 +63,7 @@ 		progressBarSetFraction pb 0 		widgetShow pb 		refresh `set` [ widgetSensitive := False ]-		Config {masterServers, delays=Delay{..}}	<- atomically $ readTMVar mconfig+		Config {masterServers, delays=delays@Delay{..}} <- atomically $ readTMVar mconfig 		 		start <- getMicroTime @@ -79,29 +74,30 @@ 		let tremTime = (packetDuplication + 1) * packetTimeout 			+ serversGuess * throughputDelay + 200 * 1000 		-		pbth <- forkIO $ whileTrue $ do-			threadDelay 10000 --10 ms, 100 fps-			now <- getMicroTime-			let diff = now - start-			if now-start > fromIntegral tremTime then do-				postGUISync $ progressBarSetFraction pb 1-				return False-			else do-				postGUISync $ progressBarSetFraction pb-					(fromIntegral diff / fromIntegral tremTime)-				return True-			 		forkIO $ do-			Config {delays} <- atomically $ readTMVar mconfig 			hosts <- catMaybes <$> mapM 				(\(host, port, proto) -> fmap (`MasterServer` proto) <$> getDNS host (show port)) 				masterServers+			pbth <- forkIO $ whileTrue $ do+				threadDelay 10000 --10 ms, 100 fps+				now <- getMicroTime+				let diff = now - start+				if now-start > fromIntegral tremTime then do+					postGUISync $ progressBarSetFraction pb 1+					return False+				else do+					postGUISync $ progressBarSetFraction pb+						(fromIntegral diff / fromIntegral tremTime)+					return True+				 			result <- pollMasters delays hosts  			atomically $ replaceTMVar mpolled result 			killThread pbth+			clans <- atomically $ readTMVar mclans 			postGUISync $ do-				polledHook+				mapM_ ($ result) polledHook+				mapM_ (\f -> f clans result) bothHook 				refresh `set` [ widgetSensitive := True ] 				widgetHide pb 		return ()@@ -110,5 +106,25 @@ 	Config {..} <- atomically $ readTMVar mconfig 	when autoMaster serverRefresh 	when autoClan doSync-	return pbrbox++	on parent keyPressEvent $  do+		kmod	<- eventModifier+		k	<- map toLower <$> eventKeyName+		case kmod of+			[Control]+				| k == "r" -> liftIO serverRefresh	>> return True+				| k == "s" -> liftIO doSync		>> return True+			[]	| k == "f5" -> liftIO serverRefresh	>> return True+			[]	| k == "f6" -> liftIO doSync		>> return True+			[]	| k == "f7" -> liftIO (newAbout parent)	>> return True+			_ -> return False 				 	+	return pbrbox+	where mkToolButton lbl icon tip = do+		button <- buttonNewWithLabel lbl+		set button	[ buttonImage		:=> imageNewFromStock icon IconSizeButton+				, buttonRelief		:= ReliefNone +				, buttonFocusOnClick	:= False+				, widgetTooltipText	:= Just tip ]+		return button+
src/TremFormatting.hs view
@@ -3,7 +3,7 @@ import Data.Char import Network.Tremulous.NameInsensitive -data TremFmt = TFColor !String | TFNone+data TremFmt = TFColor !String | TFNone !String 	deriving (Show, Read)  type ColorArray = Array Int TremFmt@@ -20,7 +20,7 @@ pangoColors arr = f False where 	f n ('^':x:xs) | isAlphaNum x = case arr ! (a `mod` 8) of 		TFColor color	-> close n ++ "<span color=\"" ++ color ++ "\">" ++ f True xs-		TFNone		-> close n ++ f False xs+		TFNone	_	-> close n ++ f False xs 		where a = ord x - ord '0'
src/Types.hs view
@@ -1,6 +1,6 @@ module Types ( 	module Control.Concurrent.STM-	, Bundle(..)+	, Bundle(..), ClanHook, PolledHook, ClanPolledHook, SetCurrent ) where import Graphics.UI.Gtk import Config@@ -13,4 +13,10 @@ 	, mconfig	:: !(TMVar Config) 	, mclans	:: !(TMVar [Clan]) 	, parent	:: !Window+	, browserStore	:: !(ListStore GameServer) 	}++type ClanHook		= [Clan] -> IO ()+type PolledHook		= PollResult -> IO ()+type ClanPolledHook	= [Clan] -> PollResult -> IO ()+type SetCurrent		= Bool -> GameServer -> IO ()