apelsin 1.1 → 1.2

raw patch · 28 files changed

+1654/−983 lines, 28 filesdep +deepseqdep −stmdep ~tremulous-query

Dependencies added: deepseq

Dependencies removed: stm

Dependency ranges changed: tremulous-query

Files

• apelsin.cabal +13/−6
• src/About.hs +6/−3
• src/Apelsin.hs +45/−51
• src/AutoRefresh.hs +63/−0
• src/ClanFetcher.hs +56/−53
• src/Clanlist.hs +70/−136
• src/ConcurrentUtil.hs +11/−0
• src/Config.hs +134/−42
• src/Constants.hs +11/−7
• src/Exception2.hs +14/−0
• src/FilterBar.hs +41/−28
• src/FindPlayers.hs +71/−41
• src/GtkExts.hs +31/−8
• src/GtkUtils.hs +120/−150
• src/IndividualServerSettings.hs +64/−0
• src/InfoBox.hs +1/−1
• src/List2.hs +20/−2
• src/Monad2.hs +24/−0
• src/NumberSerializer.hs +25/−0
• src/OnlineClans.hs +83/−0
• src/Preferences.hs +189/−129
• src/STM2.hs +0/−37
• src/ServerBrowser.hs +84/−50
• src/ServerInfo.hs +204/−122
• src/SettingsDialog.hs +89/−0
• src/Toolbar.hs +140/−94
• src/TremFormatting.hs +27/−15
• src/Types.hs +18/−8

@@ -1,5 +1,5 @@ Name:                   apelsin-Version:                1.1+Version:                1.2 Author:                 Christoffer Öjeling Maintainer:             christoffer@ojeling.net License:                GPL-3@@ -33,32 +33,39 @@ Executable apelsin   Default-Language:     Haskell2010   Default-Extensions:   BangPatterns NamedFieldPuns RecordWildCards-                        ScopedTypeVariables OverloadedStrings-  Other-Extensions:     CPP-  Build-Depends:        base>=4.3&&<5, array, mtl, stm, containers, transformers,+                        ScopedTypeVariables OverloadedStrings TupleSections GADTs+  Other-Extensions:     CPP StandaloneDeriving+  Build-Depends:        base>=4.3&&<5, array, mtl, containers, transformers,                         bytestring, directory, filepath, HTTP, network,-                        tremulous-query>=1.0.2, gtk, glib, process+                        tremulous-query>=1.0.5, gtk, glib, process, deepseq   Hs-Source-Dirs:       src   Main-is:              Apelsin.hs   Other-Modules:        System.Environment.XDG.BaseDir                         GtkExts                         About+                        AutoRefresh                         ClanFetcher                         Clanlist                         Config                         Constants+                        ConcurrentUtil+                        Exception2                         FilterBar                         FindPlayers                         GtkUtils+                        IndividualServerSettings                         InfoBox                         List2+                        Monad2+                        NumberSerializer                         Preferences                         ServerBrowser                         ServerInfo-                        STM2+                        SettingsDialog                         Toolbar                         TremFormatting                         Types+                        OnlineClans                         Paths_apelsin    Ghc-Options:          -Wall -threaded -fno-warn-unused-do-bind -funbox-strict-fields

@@ -1,16 +1,19 @@ module About where import Graphics.UI.Gtk import Constants+import Data.Version+import Paths_apelsin (version)  newAbout :: WindowClass w => w -> IO () newAbout win = do 	about <- aboutDialogNew 	aboutDialogSetUrlHook openInBrowser-	set about [-		  windowWindowPosition := WinPosCenterOnParent++	set about+		[ windowWindowPosition	:= WinPosCenterOnParent 		, windowTransientFor	:= win 		, aboutDialogProgramName:= programName-		, aboutDialogVersion	:= "1.1"+		, aboutDialogVersion	:= showVersion version 		, aboutDialogCopyright	:= "Copyright © 2011\nChristoffer Öjeling <christoffer@ojeling.net>" 		, aboutDialogComments	:= "A tremulous server and community browser\nLicense: GPLv3" 		, aboutDialogWebsite	:= "http://ojeling.net"

@@ -1,51 +1,66 @@ import Graphics.UI.Gtk import System.Glib.GError -import Control.Applicative import Control.Monad.IO.Class-import Control.Exception import Control.Monad-import Data.Char (toLower)-import qualified Data.Set as S+import Control.Exception+import Data.Char (ord) import Network.Socket import Network.Tremulous.Protocol+import Control.Concurrent import System.FilePath (joinPath) +import Exception2+import Monad2+import List2 import Types import Constants-import GtkUtils import ServerInfo import ServerBrowser import FindPlayers import Clanlist+import OnlineClans import ClanFetcher import Preferences import Config import Toolbar+import IndividualServerSettings as ISS  main :: IO () main = withSocketsDo $ do 	unsafeInitGUIForThreadedRTS 	win		<- windowNew 	config		<- configFromFile-	cacheclans	<- clanListFromCache+	settings	<- ISS.fromFile+ 	bundle	<-	(do-			mpolled		<- atomically $ newTMVar (PollResult [] 0 0 S.empty)-			mconfig		<- atomically $ newTMVar config-			mclans		<- atomically $ newTMVar cacheclans+			mpolled		<- newMVar (PollResult [] 0 0)+			mconfig		<- newMVar config+			mclans		<- newMVar []+			mrefresh	<- newEmptyMVar 			browserStore	<- listStoreNew []+			playerStore	<- listStoreNew []+			msettings	<- newMVar settings+			mauto		<- newEmptyMVar 			return Bundle {parent = win, ..} 			)-	mupdate <- atomically newEmptyTMVar++	mupdate <- newEmptyMVar 	(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+	(browser, browserUpdate)		<- newServerBrowser bundle currentSet+	(findPlayers, findUpdate)		<- newFindPlayers bundle currentSet+	(clanlist, clanlistUpdate)		<- newClanList bundle currentSet 	(onlineclans, onlineclansUpdate)	<- newOnlineClans bundle currentSet  	preferences				<- newPreferences bundle-	atomically $ putTMVar mupdate (findUpdate, onlineclansUpdate)+	putMVar mupdate (findUpdate, onlineclansUpdate) +	forkIO $ do+		cache <- clanListFromCache+		swapMVar (mclans bundle) cache+		postGUISync $ clanlistUpdate cache =<< readMVar (mpolled bundle)++ 	toolbar <- newToolbar bundle 		[] 		[browserUpdate, findUpdate, currentUpdate]@@ -62,8 +77,8 @@ 	leftView <- vBoxNew False 0 	boxPackStart leftView toolbar PackNatural 0 	boxPackStart leftView book PackGrow 0-	 + 	pane <- hPanedNew 	panedPack1 pane leftView True False 	panedPack2 pane currentInfo  False True@@ -71,7 +86,7 @@  	-- save the current window size and pane positon on exit 	on win deleteEvent $ tryEvent $ liftIO $ do-		Config {autoGeometry} <- atomically $ readTMVar (mconfig bundle)+		Config {autoGeometry} <- readMVar (mconfig bundle) 		when autoGeometry $ do 			file		<- inCacheDir "windowsize" 			(winw, winh)	<- windowGetSize win@@ -80,24 +95,20 @@ 		mainQuit  	ddir <- getDataDir-	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"]-		icons <- mapM pixbufNewFromFile list-		set win [ windowIconList := icons]-	+	handle (\(_::GError) -> trace $ "Window icon not found in: " ++ ddir) $ do+		let list = map (iconPath ddir) ["16", "32", "48", "64"]+		windowSetDefaultIconList =<< mapM pixbufNewFromFile list+ 	-- Without allowshrink the window may change size back and forth when selecting new servers 	set win [ containerChild	:= pane 		, windowTitle		:= fullProgramName-		, windowAllowShrink	:= True-		]+		, windowAllowShrink	:= True ]  	--Showing it to get size requests 	widgetShowAll leftView  	-- Restore the window size and pane position-	when (autoGeometry config) $ handle ignoreIOException $ do+	when (autoGeometry config) $ ignoreIOException $ do 		file	<- inCacheDir "windowsize" 		fx	<- readFile file 		whenJust (mread fx) $ \(winw::Int, winh, ppos::Int) -> do@@ -109,31 +120,14 @@ 				, widgetWidthRequest	:= max (minw+panebuf) winw ] 	widgetShowAll win -	on win keyPressEvent $  do+	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+		k	<- eventKeyVal+		let page = fromIntegral k - ord '0' - 1+		if kmod == [Alt] && page >= 0 && page <= 5+			then liftIO (notebookSetCurrentPage book page) >> return True+			else return False 	mainGUI --ignoreIOException :: IOException -> IO ()-ignoreIOException _ = return ()--+iconPath :: FilePath -> FilePath -> FilePath+iconPath ddir x = joinPath [ddir, "icons", "hicolor", x ++ "x" ++ x, "apps", configName++".png"]

@@ -0,0 +1,63 @@+module AutoRefresh (AutoSignal(..), autoSignal, autoRunner) where+import Control.Applicative+import Control.Concurrent+import Control.Exception+import Control.Monad++import Network.Tremulous.MicroTime+import Monad2+import Config++data AutoSignal = AutoUpdate | AutoStop | AutoStart | AutoPause | AutoResume+	deriving Show++data State = Running !ThreadId | Paused | Stopped++autoSignal :: MVar AutoSignal -> AutoSignal -> IO ()+autoSignal m = putMVar m++autoRunner :: MVar AutoSignal -> MVar Config -> IO a -> IO ThreadId+autoRunner m mconfig refreshAction = forkIO $ go Stopped Nothing+	where+	go :: State -> Maybe MicroTime -> IO a+	go state timestamp = do+		st <- takeMVar m+		case st of+			AutoStart -> case state of+				Running _ -> go state timestamp+				_ -> do	tid <- startAuto mconfig timestamp refreshAction+					go (Running tid) timestamp++			AutoStop -> case state of+				Running tid -> killThread tid >> go Stopped timestamp+				_ -> go Stopped timestamp++			AutoUpdate -> do+				timestamp' <- Just <$> getMicroTime+				case state of+					Running tid -> do+						killThread tid+						tid' <- startAuto mconfig timestamp' refreshAction+						go (Running tid') timestamp'+					_ -> go state timestamp'++			AutoPause | Running tid <- state -> do+				killThread tid+				go Paused timestamp++			AutoResume | Paused <- state -> do+				tid <- startAuto mconfig timestamp refreshAction+				go (Running tid) timestamp++			_ -> go state timestamp+++startAuto :: MVar Config -> Maybe MicroTime -> IO a -> IO ThreadId+startAuto mconfig lastRefresh refreshAction = uninterruptibleMask $ \restore -> forkIO $ do+		delay <- autoDelay <$> readMVar mconfig+		whenJust lastRefresh $ \past -> do+			now <- getMicroTime+			when (past+delay > now) $+				restore $ threadDelay (fromIntegral (past+delay-now))+		refreshAction+		return ()

@@ -1,26 +1,29 @@-module ClanFetcher( -	Clan(..), TagExpr, matchTagExpr, prettyTagExpr, tagExprGet, getClanList, clanListFromCache+module ClanFetcher(+	Clan(..), TagExpr, ClanID, matchTagExpr, prettyTagExpr, tagExprGet, getClanList, clanListFromCache+	, matchClanByID ) where -import Prelude as P hiding (catch)-import Control.Exception+import Prelude as P import Control.Applicative+import Control.Exception import Control.Monad import Data.ByteString.Char8 as B import Data.ByteString.Lazy.Char8 as L-import Data.Char (intToDigit)+import Data.List as List import Data.Maybe import Data.Ord import Network.Socket import Network.HTTP+import Network.Stream import Network.URI import Network.Tremulous.NameInsensitive-import TremFormatting +import TremFormatting import Constants+import Monad2 -data TagExpr =-	  TagPrefix !TI+data TagExpr+	= TagPrefix !TI 	| TagSuffix !TI 	| TagInfix !TI 	| TagContained !TI !TI@@ -29,21 +32,29 @@ instance Ord TagExpr where 	compare = comparing tagExprGet -tagExprGet :: TagExpr -> B.ByteString+tagExprGet :: TagExpr -> TI tagExprGet x = case x of-	TagPrefix (TI _ v)	-> v-	TagSuffix (TI _ v)	-> v-	TagInfix (TI _ v)	-> v-	TagContained (TI _ v) _	-> v+	TagPrefix v		-> v+	TagSuffix v		-> v+	TagInfix v		-> v+	TagContained v _	-> v -data Clan = Clan {-	  name		:: !TI+type ClanID = Int+data Clan = Clan+	{ clanID	:: !ClanID+	, name		:: !TI 	, website 	, irc		:: !B.ByteString+	, websitealive	:: !Bool 	, tagexpr	:: !TagExpr 	, clanserver	:: !(Maybe SockAddr) 	} +matchClanByID :: [Clan] -> TI -> ClanID -> Bool+matchClanByID clans raw cid = case List.find (\x -> clanID x == cid) clans of+	Just a -> matchTagExpr (tagexpr a) raw+	Nothing -> False+ mkTagExpr :: B.ByteString -> Maybe TagExpr mkTagExpr str 	| Just (x, xs) <- B.uncons str = case x of@@ -63,23 +74,24 @@ 	TagContained (TI _ xs) (TI _ ys)-> xs `B.isPrefixOf` str && ys `B.isSuffixOf` str 	where str = cleanedCase raw -prettyTagExpr :: TagExpr -> String+prettyTagExpr :: TagExpr -> B.ByteString 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+	TagPrefix bs	-> esc bs `B.append` wild+	TagSuffix bs	-> wild `B.append` esc bs+	TagInfix bs	-> B.concat [wild, esc bs, wild]+	TagContained a b-> B.concat [esc a, wild, esc b] 	where	wild = "<span color=\"#BBB\">*</span>"-		esc  = htmlEscape . B.unpack . original+		esc  = htmlEscapeBS . original   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]+rawToClan = fmap sequence . mapM (f . B.split '\t' . lazyToStrict) . P.filter (not . L.null) . L.split '\n' where+	f (rclanID:rname:rexpr:website:rwebsitealive:irc:rserver:_) 		| Just tagexpr <- mkTagExpr rexpr-		= do+		, Just (clanID,_) <- B.readInt rclanID = do 			let	(ip, port1)	= B.break (==':') rserver 				port		= B.drop 1 port1+				websitealive	= rwebsitealive == "1" 			clanserver <- if B.null ip || B.null port 				then return Nothing 				else getDNS (B.unpack ip) (B.unpack port)@@ -90,46 +102,37 @@ getClanList url = do 	cont <- get url 	case cont of-		Right _ -> return Nothing-		Left raw -> do-			file	<- inCacheDir "clans"+		Nothing -> return Nothing+		Just raw -> do+			file	<- cacheFile 			clans	<- rawToClan raw 			when (isJust clans) $ 				L.writeFile file raw- 			return clans-			 + clanListFromCache :: IO [Clan] clanListFromCache = handle err $ do-	file	<- inCacheDir "clans"+	file <- cacheFile 	fromMaybe [] <$> (rawToClan =<< L.readFile file) 	where-	err (_ :: IOError) = return [] -	+	err (_ :: IOException) = return [] -lazyToStrict :: L.ByteString -> B.ByteString		++lazyToStrict :: L.ByteString -> B.ByteString lazyToStrict = B.concat . toChunks +cacheFile :: IO FilePath+cacheFile = inCacheDir "clans" --- I blame this on buggy Network.HTTP-get :: HStream ty => String -> IO (Either ty String)-get url = case parseURI url of-		Nothing -> return $ Right "Error in URL"-		Just uri -> do-			resp <- catch (getRight `fmap` simpleHTTP (mkRequest GET uri)) err-			return $ case resp of-				Left msg				-> Right $ show msg-				Right (Response (2,0,0) _  _ body)	-> Left body-				Right (Response code reason _ _)	-> Right $ showRspCode code  ++ " " ++ reason-	where-	showRspCode (a,b,c) = P.map intToDigit [a,b,c]-	getRight (Right a) = Right a-	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+get :: HStream ty => String -> IO (Maybe ty)+get url = case parseURI url of+	Nothing -> return Nothing+	Just uri -> do+		resp <- ex $ simpleHTTP (mkRequest GET uri)+		return $ case resp of+			Right (Response (2,0,0) _  _ body)	-> Just body+			_					-> Nothing+	-- It doesn't catch everything apparently+	where ex = handle (\(_ :: IOException) -> return (Left ErrorReset))

@@ -1,42 +1,38 @@-module Clanlist (newClanList, newClanSync, newOnlineClans) where-+module Clanlist (newClanList) 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 import Data.Maybe-import Data.List (sortBy) import Data.IORef import Network.Tremulous.NameInsensitive import Network.Tremulous.ByteStringUtils import qualified Network.Tremulous.Protocol as P+import qualified Network.Tremulous.StrictMaybe as SM import Network.Tremulous.Util  import Types import ClanFetcher import Constants-import Config import FilterBar import InfoBox import GtkUtils-import TremFormatting+import GtkExts+import Monad2+import Config  -newClanList :: Bundle -> [Clan] -> SetCurrent -> IO (VBox, ClanPolledHook, Entry)-newClanList Bundle{..} cache setCurrent = do-	raw			<- listStoreNew []-	filtered		<- treeModelFilterNew raw []-	sorted			<- treeModelSortNewWithModel filtered-	view			<- treeViewNewWithModel sorted+newClanList :: Bundle -> SetCurrent -> IO (VBox, ClanPolledHook)+newClanList bundle@Bundle{..} setCurrent = do+	gen@(GenFilterSort raw filtered sorted view)+		<- newGenFilterSort =<< listStoreNew [] 	scrollview		<- scrollIt view PolicyAutomatic PolicyAlways  	(infobox, statNow, statTot) <- newInfobox "clans" -	(filterbar, current, ent)	<- newFilterBar filtered statNow ""+	(filterbar, current) <- newFilterBar parent filtered statNow ""  	let updateF newraw P.PollResult{..} = do 		let new = (`map` newraw) $ \c -> case clanserver c of@@ -45,146 +41,84 @@ 		listStoreClear raw 		treeViewColumnsAutosize view 		mapM_ (listStoreAppend raw) new-		treeModelFilterRefilter filtered-		set statTot [ labelText := show (length new) ]-		n <- treeModelIterNChildren filtered Nothing-		set statNow [ labelText := show n ]+		labelSetText statTot . show =<< treeModelIterNChildren raw Nothing+		labelSetText statNow . show =<< treeModelIterNChildren filtered 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)-		]+	addColumnFS gen "" False (Just $ comparing $ isJust . clanserver . fst)+		(rememberColumn bundle 0)+		cellRendererPixbufNew [] haveServer +	addColumnFS gen "_Name" False (Just $ comparing $ name . fst)+		(rememberColumn bundle 1)+		cellRendererTextNew [] (simpleColumn (original . name))++	addColumnFS gen "_Tag" False (Just $ comparing $ tagexpr . fst)+		(rememberColumn bundle 2)+		cellRendererTextNew [] (markupColumn (prettyTagExpr . tagexpr))++	addColumnFS gen "Website" False Nothing+		(const (return ()))+		cellRendererTextNew [] $ \rend (Clan{..},_) -> do+			set rend $ if websitealive+				then [ cellTextStrikethrough := False, cellTextUnderline := UnderlineSingle, cellTextForegroundColor := Color 0 0 maxBound ]+				else [ cellTextStrikethrough := True, cellTextUnderline := UnderlineNone, cellTextForegroundColor := Color maxBound 0 0 ]+			cellSetMarkup rend (showURL website)++	addColumnFS gen "IRC" False Nothing+		(const (return ()))+		cellRendererTextNew [] (simpleColumn irc)++	Config{..} <- readMVar mconfig+	treeSortableSetSortColumnId sorted clanlistSort clanlistOrder++ 	treeModelFilterSetVisibleFunc filtered $ \iter -> do 		(Clan{..}, _)	<- treeModelGetRow raw iter 		s		<- readIORef current-		let cmplist	= [ cleanedCase name, tagExprGet tagexpr ]-		return $ B.null s || smartFilter s cmplist+		return $ smartFilter s	[ cleanedCase name+					, cleanedCase (tagExprGet tagexpr) ]  	on view cursorChanged $ do-		(path, _)		<- treeViewGetCursor view-		(Clan{..}, active)	<- getElementFS raw sorted filtered path-		+		(path, col)		<- treeViewGetCursor view+		(Clan{..}, active)	<- getElementPath gen path+		title			<- maybe (return Nothing) treeViewColumnGetTitle col++		when (title == Just "Website" && (not . B.null) website) $ openInBrowser $+			if websitealive then B.unpack website+					else "http://wayback.archive.org/web/*/" ++ (B.unpack website)+ 		when active $ whenJust clanserver $ \server -> do-			P.PollResult{..} <- atomically $ readTMVar mpolled+			P.PollResult{..} <- readMVar 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)+	on view rowActivated $ \path col -> do+		(Clan{..}, active) <- getElementPath gen path+		title <- treeViewColumnGetTitle  col+		case title of+			Just "Website" -> return ()+			_ -> when active $ whenJust clanserver $ \server -> do+				P.PollResult{..} <- readMVar mpolled+				whenJust (serverByAddress server polled) (setCurrent True)  	box <- vBoxNew False 0 	boxPackStart box filterbar PackNatural spacing 	boxPackStart box scrollview PackGrow 0 	boxPackStart box infobox PackNatural 0 -	-	updateF cache =<< atomically (readTMVar mpolled)--	return (box, updateF, ent)+	return (box, updateF) 	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+	showURL x = SM.fromMaybe x (stripPrefix "http://" x)+	markupColumn f rend (item, _) = cellSetMarkup rend (f item)+	simpleColumn f rend (item, _) = cellSetText rend (f item)+	haveServer rend (Clan{..}, active) = set rend $ case clanserver of 		Just _	-> [cellPixbufStockId := stockNetwork, cellSensitive := active] 		Nothing	-> [cellPixbufStockId := ""]  -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 (name, _)		-> pangoPretty colors name--	let showServer c =  case c of-		Left _ -> ""-		Right (_, P.GameServer{hostname}) -> pangoPretty colors hostname--	raw	<- treeStoreNew []-	view	<- treeViewNewWithModel raw--	treeViewExpandAll view-	addColumns raw view [-		  ("Name"	, 0	, True	, True	, True	, showName )-		, ("Server"	, 0	, True	, True	, True	, showServer )-		]--	let updateF clans P.PollResult{..} = do-		let players = buildTree $ sortByPlayers $-			associatePlayerToClans (makePlayerNameList polled) clans-		treeStoreClear raw-		treeViewColumnsAutosize view-		mapM_ (treeStoreInsertTree raw [] 0) players-		treeViewExpandAll view--	on view cursorChanged $ do-		(path, _)	<- treeViewGetCursor view-		item		<- getElement raw path-		case item of-			Left _ -> return ()-			Right (_, a) -> setServer False a--	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 = [(TI, 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 . fst--buildTree :: [(Clan, PlayerList)] -> OnlineView-buildTree = filter notEmpty . foldr f [] where-	f (clan, pls) xs = Node (Left clan) (map rightNode pls) : xs-	rightNode x = Node (Right x) []-	notEmpty (Node _ [])	= False-	notEmpty _		= True--sortByPlayers :: [(Clan, [b])] -> [(Clan, [b])]-sortByPlayers = sortBy (flip (comparing (\(a, b) -> (-length b, name a))))--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 ]-	return ()+rememberColumn :: Bundle -> Int -> TreeViewColumn -> IO ()+rememberColumn Bundle{..} n col = do+	order <- treeViewColumnGetSortOrder col+	current <- takeMVar mconfig+	let new = current {clanlistSort = n, clanlistOrder = order}+	putMVar mconfig new+	configToFile parent new

@@ -0,0 +1,11 @@+module ConcurrentUtil where++import Control.Concurrent+import Control.Exception++readWithMVar :: MVar m -> (m -> IO ()) -> IO ()+readWithMVar m f = mask $ \restore -> do+	ret <- tryTakeMVar m+	case ret of+		Just a  -> putMVar m a >> restore (f a)+		Nothing -> return ()

@@ -1,74 +1,166 @@-module Config where-+module Config (Config(..), ColorTheme, configFromFile, configToFile+	, makeColorsFromList, RefreshMode(..)+) where+import Graphics.UI.Gtk (SortType(..), Window) import Data.Array+import Data.Char import Control.Exception+import Control.Applicative import Network.Tremulous.Protocol+import Control.Monad.State.Strict+import Network.Tremulous.TupleReader (lookupDelete)+import Network.Tremulous.StrictMaybe as SM+import Network.Tremulous.MicroTime  import Constants+import List2 import GtkUtils import TremFormatting - type ColorTheme = Array Int TremFmt -data Config = Config {-	  configVersion	:: !Int-	, masterServers :: ![(String, Int, Int)]+data SortingOrderPretty = Ascending | Descending+	deriving (Show, Read, Enum)++data RefreshMode = Startup | Auto | Manual+	deriving (Show, Read, Eq)++data Config = Config+	{ masterServers :: ![(String, Int, Int)] 	, clanSyncURL	:: !String 	, tremPath 	, tremGppPath	:: !String-	, autoMaster+	, refreshMode	:: !RefreshMode 	, autoClan 	, autoGeometry	:: !Bool+	, autoDelay	:: !MicroTime 	, filterBrowser 	, filterPlayers	:: !String 	, filterEmpty	:: !Bool+	, browserSort+	, playersSort+	, clanlistSort	:: !Int+	, browserOrder+	, playersOrder+	, clanlistOrder	:: !SortType 	, delays	:: !Delay 	, colors	:: !ColorTheme-	} deriving (Show, Read)+	} -defaultConfig :: Config-defaultConfig = Config {-	  configVersion	= 1-	, masterServers = [("master.tremulous.net", 30710, 69), ("master.tremulous.net", 30700, 70)]-	, clanSyncURL	= "http://ddos-tremulous.eu/cw/api/clanlist"-	, tremPath	= defaultTremulousPath-	, tremGppPath	= defaultTremulousGPPPath-	, autoMaster	= True-	, autoClan	= True-	, autoGeometry	= True-	, filterBrowser	= ""-	, filterPlayers	= ""-	, filterEmpty	= True-	, delays	= defaultDelay-	, colors	= makeColorsFromList $-		TFNone "#000000" : map TFColor ["#d60503", "#25c200", "#eab93d", "#0021fe", "#04c9c9", "#e700d7"] ++ [TFNone "#000000"]-	} ++newSave :: Config -> String+newSave Config{delays=Delay{..}, ..} = unlines $+	[ f masterServers	mastersText+	, f clanSyncURL		clanText+	, f tremPath		t11Text+	, f tremGppPath		t12Text+	, f refreshMode		refreshModeText+	, f autoClan		autoClanText+	, f autoGeometry	geometryText+	, f (autoDelay`quot`1000000) autoDelayText+	, f filterBrowser	browserfilterText+	, f filterPlayers	playerfilterText+	, f filterEmpty		showEmptyText+	, f browserSort		browserSortText+	, f playersSort		playerSortText+	, f clanlistSort	clanlistSortText+	, f (conv browserOrder)	browserOrderText+	, f (conv playersOrder)	playerOrderText+	, f (conv clanlistOrder) clanlistOrderText+	, f packetTimeout	packetTimeoutText+	, f packetDuplication	packetDuplicationText+	, f throughputDelay	throughputDelayText+	] +++	zipWith (\a b -> f b (colorText ++ [a])) ['0'..'7'] (elems colors)+	where+	conv :: SortType -> SortingOrderPretty+	conv = toEnum . fromEnum+	f :: Show v => v -> String -> String+	f v k = k ++ " " ++ show v++newParse :: [(String, String)] -> Config+newParse = evalState $ do+	masterServers	<- f mastersText		[("master.tremulous.net", 30710, 69), ("master.tremulous.net", 30700, 70)]+	clanSyncURL	<- f clanText			"http://ddos-tremulous.eu/cw/api/2/clanlist"+	tremPath	<- f t11Text			defaultTremulousPath+	tremGppPath	<- f t12Text			defaultTremulousGPPPath+	refreshMode	<- f refreshModeText		Startup+	autoClan	<- f autoClanText		True+	autoGeometry	<- f geometryText		True+	autoDelay	<- (*1000000) <$> f autoDelayText		120 -- 120s+	filterBrowser	<- f browserfilterText		""+	filterPlayers	<- f playerfilterText		""+	filterEmpty	<- f showEmptyText		True+	browserSort	<- f browserSortText		3+	playersSort	<- f playerSortText		0+	clanlistSort	<- f clanlistSortText		1+	browserOrder	<- toEnum . fromEnum <$> f browserOrderText	Ascending+	playersOrder	<- toEnum . fromEnum <$> f playerOrderText	Ascending+	clanlistOrder	<- toEnum . fromEnum <$> f clanlistOrderText	Ascending+	packetTimeout	<- f packetTimeoutText	(packetTimeout defaultDelay)+	packetDuplication<- f packetDuplicationText	(packetDuplication defaultDelay)+	throughputDelay	<- f throughputDelayText	(throughputDelay defaultDelay)+	colors		<- makeColorsFromList <$> zipWithM (\a b -> f (colorText ++ [a]) b) ['0'..'7'] defaultColors+	return Config{delays = Delay{..}, ..}+	where+	f :: Read b  => String -> b -> State [(String, String)] b+	f key d = do+		s <- get+		let (e, s') = lookupDelete key s+		put s'+		return $ SM.fromMaybe d $ smread =<< e+	defaultColors = TFNone "#000000" : map TFColor ["#d60503", "#25c200", "#eab93d", "#0021fe", "#04c9c9", "#e700d7"] ++ [TFNone "#000000"]++smread :: (Read a) => String -> SM.Maybe a+smread x = case reads x of+	[(a, _)]	-> SM.Just a+	_		-> SM.Nothing++parse :: String -> Config+parse = newParse . map (breakDrop isSpace) . lines++mastersText, clanText, t11Text, t12Text, refreshModeText, autoClanText, geometryText, autoDelayText+	, browserfilterText, playerfilterText, showEmptyText, browserSortText, playerSortText+	, browserOrderText, playerOrderText, packetTimeoutText, clanlistSortText, clanlistOrderText+	, packetDuplicationText, throughputDelayText, colorText :: String+mastersText		= "masters"+clanText		= "clanlistUrl"+t11Text			= "tremulous1.1"+t12Text			= "tremulousGPP"+refreshModeText		= "refreshMode"+autoClanText		= "autoClan"+geometryText		= "saveGeometry"+autoDelayText		= "autoDelay"+browserfilterText	= "browserFilter"+playerfilterText	= "playersFilter"+showEmptyText		= "showEmpty"+browserSortText		= "browserSortColumn"+playerSortText		= "playerSortColumn"+clanlistSortText	= "clanlistSortColumn"+browserOrderText	= "browserSortingOrder"+playerOrderText		= "playerSortingOrder"+clanlistOrderText	= "clanlistSortingOrder"+packetTimeoutText	= "packetTimeout"+packetDuplicationText	= "packetDuplication"+throughputDelayText	= "throughputDelay"+colorText		= "color"+ makeColorsFromList :: [e] -> Array Int e makeColorsFromList = listArray (0,7) -configToFile :: Config -> IO ()-configToFile config = handle err $ do-	file	<- inConfDir "config"-	writeFile file (show config)+configToFile :: Window -> Config -> IO ()+configToFile win config = do+	file <- inConfDir "config"+	handle err $ do+	writeFile file (newSave config) 	where-	err (_::IOError) = gtkWarn "Error saving config file"+	err (e::IOError) = gtkWarn win $ "Unable to save settings:\n" ++ show e   configFromFile :: IO Config configFromFile = handle err $ do 	file	<- inConfDir "config" 	cont	<- readFile file-	case mread cont of-		Nothing -> do-			gtkWarn $ "Errors in " ++ file ++ "!\nUsing default"-			return defaultConfig-		Just a -> return a+	return $ parse cont 	where-	err (_::IOError) = return defaultConfig--mread :: (Read a) => String -> Maybe a-mread x = case reads x of-	[(a, _)]	-> Just a-	_		-> Nothing-+	err (_::IOError) = return $ parse ""

@@ -6,10 +6,11 @@ import System.Directory import System.IO import System.Process+import Control.Concurrent import Control.Exception  #ifdef CABAL_PATH-import Paths_apelsin+import Paths_apelsin hiding (getDataDir) #endif  configName, programName, fullProgramName :: IsString s => s@@ -30,7 +31,7 @@ 	return (dir </> x)  -getDataDir :: IO FilePath +getDataDir :: IO FilePath #ifdef CABAL_PATH getDataDir = dropTrailingPathSeparator `fmap` getDataFileName "" #else@@ -63,13 +64,16 @@  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}+	p <- defaultBrowser x+	(_,_,_,hdl) <- createProcess p {close_fds = True}+	-- The following hack is needed to avoid ghost processes because of:+	-- http://hackage.haskell.org/trac/ghc/ticket/2123+	forkIO $ waitForProcess hdl >> return () 	return () -spacing, spacingHalf, spacingBig :: Integral i => i-spacing		= 4+spacing, spacingHalf, spacingBig, spacingHuge :: Integral i => i spacingHalf	= 2+spacing		= 4 spacingBig	= 8+spacingHuge	= 12 

@@ -0,0 +1,14 @@+module Exception2 where+import Control.Exception++maybeIO :: IO (Maybe a) -> IO (Maybe a)+maybeIO = handleIOWith Nothing++tryIO :: IO a -> IO Bool+tryIO f = handleIOWith False (f >> return True)++ignoreIOException :: IO () -> IO ()+ignoreIOException = handleIOWith ()++handleIOWith :: a -> IO a -> IO a+handleIOWith w = handle (\(_ :: IOException) -> return w)

@@ -4,7 +4,8 @@ import Data.IORef import qualified Data.ByteString.Char8 as B import Data.ByteString.Char8 (ByteString)-import Data.Char+import Data.Char hiding (Control)+import Control.Applicative import Control.Monad.IO.Class import Network.Tremulous.ByteStringUtils as B @@ -12,53 +13,65 @@ import Constants  -newFilterBar :: (TreeModelClass self, TreeModelFilterClass self) => self -> Label -> String-	-> IO (HBox, IORef ByteString, Entry)-newFilterBar filtered stat initial  = do-	current <- newIORef ""-	+newFilterBar :: (TreeModelClass self, TreeModelFilterClass self) => Window -> self -> Label -> String+	-> IO (HBox, IORef [Expr])+newFilterBar win filtered stat initial  = do+	current <- newIORef []+ 	-- Filterbar 	ent <- entryNew 	set ent [ entryText := initial ] 	entrySetIconFromStock ent EntryIconSecondary stockClear-		+ 	lbl <- labelNew (Just "Filter:") 	set lbl [ widgetTooltipText := Just "Ctrl+L or Ctrl+F" ]-	+ 	findbar <- hBoxNew False 0 	boxPackStart findbar lbl PackNatural spacingHalf 	boxPackStart findbar ent PackGrow spacingHalf-	+ 	let f = do-		rawstr <- entryGetText ent-		let str = B.pack $ map toLower rawstr-		writeIORef current str+		str <- entryGetText ent+		writeIORef current (stringToExpr str) 		treeModelFilterRefilter filtered-		n <- treeModelIterNChildren filtered Nothing-		set stat [ labelText := show n ]-	f +		labelSetText stat . show =<< treeModelIterNChildren filtered Nothing+	f 	on ent editableChanged f  	on ent entryIconPress $-		const $ liftIO $editableDeleteText ent 0 (-1)-	-	return (findbar, current, ent)+		const $ liftIO $ editableDeleteText ent 0 (-1) -	+	on win keyPressEvent $ do+		s	<- eventModifier+		k	<- fromIntegral . keyvalToLower <$> eventKeyVal+		b 	<- liftIO $ widgetGetMapped ent+		if b && s == [Control] && (k == ord 'f' || k == ord 'l')+			then liftIO (widgetGrabFocus ent) >> return True+			else return False++	-- Focus on start+	on ent showSignal $ widgetGrabFocus ent++	return (findbar, current)++ data Expr = Is !ByteString | Not !ByteString  mkExpr :: ByteString -> Expr-mkExpr ss = case (B.head ss, B.tail ss) of-	('-', xs) | B.length xs > 0	-> Not (B.tail ss)-                  | otherwise		-> Is xs                 -	_				-> Is ss+mkExpr ss = case B.uncons ss of+	Just ('-', xs)	| B.length xs > 0	-> Not (B.tail ss)+			| otherwise		-> Is xs+	_					-> Is ss  matchExpr :: Expr -> [ByteString] -> Bool matchExpr (Is xs)  = any (xs `B.isInfixOf`) matchExpr (Not xs) = all (not . (xs `B.isInfixOf`)) -smartFilter :: ByteString -> [ByteString] -> Bool-smartFilter raw xs = all (`matchExpr` xs) search -	where-	search	= map mkExpr (B.splitfilter ' ' raw)-	+stringToExpr :: String -> [Expr]+stringToExpr = map mkExpr . B.splitfilter ' ' . B.pack . map toLower++smartFilter :: [Expr]-> [ByteString] -> Bool+smartFilter [] 	_	= True+smartFilter expr xs	= all (`matchExpr` xs) expr++

@@ -1,71 +1,101 @@-module FindPlayers where+module FindPlayers (newFindPlayers, playerUpdateOne) where import Graphics.UI.Gtk  import Data.IORef import Data.Ord-import qualified Data.ByteString.Char8 as B+import Control.Concurrent import Network.Tremulous.Protocol import Network.Tremulous.Util+import qualified Network.Tremulous.StrictMaybe as SM  import Types import GtkUtils+import GtkExts import TremFormatting import FilterBar import InfoBox import Constants import Config -newFindPlayers :: Bundle -> SetCurrent -> IO (VBox, PolledHook, Entry)-newFindPlayers Bundle{..} setServer = do-	Config {..}	<- atomically $ readTMVar mconfig-	raw		<- listStoreNew []-	filtered	<- treeModelFilterNew raw []-	sorted		<- treeModelSortNewWithModel filtered	-	view		<- treeViewNewWithModel sorted-	-	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))) -		] +newFindPlayers :: Bundle -> SetCurrent -> IO (VBox, PolledHook)+newFindPlayers bundle@Bundle{..} setServer = do+	Config {..} <- readMVar mconfig+	(GenFilterSort raw filtered _ view) <- playerLikeList bundle setServer+ 	(infobox, statNow, statTot)	<- newInfobox "players"-	(filterbar, current, ent)	<- newFilterBar filtered statNow filterPlayers-	+	(filterbar, current)		<- newFilterBar parent filtered statNow filterPlayers+ 	treeModelFilterSetVisibleFunc filtered $ \iter -> do 		(item, GameServer{..}) <- treeModelGetRow raw iter 		s <- readIORef current-		return $ B.null s || smartFilter s [-				  cleanedCase item+		return $ smartFilter s+				[ cleanedCase item 				, proto2string protocol-				, maybe "" cleanedCase gamemod+				, SM.maybe "" cleanedCase gamemod 				]-		+ 	let updateFilter PollResult{..} = do 		listStoreClear raw-		let plist = makePlayerNameList polled-		mapM_ (listStoreAppend raw) plist-		treeModelFilterRefilter filtered-		set statTot [ labelText := show (length plist) ]-		n <- treeModelIterNChildren filtered Nothing-		set statNow [ labelText := show n ]-						-	on view cursorChanged $ do-		(path, _) <- treeViewGetCursor view-		setServer False . snd =<< getElementFS raw sorted filtered path+		mapM_ (listStoreAppend raw) (makePlayerNameList polled)+		labelSetText statTot . show =<< treeModelIterNChildren raw Nothing+		labelSetText statNow . show =<< treeModelIterNChildren filtered Nothing -	on view rowActivated $ \path _ -> do-		setServer True . snd =<< getElementFS raw sorted filtered path-	 	scroll <- scrollIt view PolicyAutomatic PolicyAlways-	+ 	box <- vBoxNew False 0 	boxPackStart box filterbar PackNatural spacing 	boxPackStart box scroll PackGrow 0 	boxPackStart box infobox PackNatural 0-	-	return (box, updateFilter, ent)-	where simpleColumn colors f item =-		[ cellTextEllipsize := EllipsizeEnd-		, cellTextMarkup := Just (pangoPretty colors (f item)) ]++	return (box, updateFilter)++playerLikeList :: Bundle -> SetCurrent -> IO (GenFilterSort ListStore (TI, GameServer))+playerLikeList bundle@Bundle{..} setCurrent= do+	Config {..} <- readMVar mconfig+	gen@(GenFilterSort _ _ sorted view) <- newGenFilterSort playerStore++	addColumnFS gen "_Name" True (Just (comparing fst))+		(rememberColumn bundle 0)+		cellRendererTextNew+		[cellTextEllipsize := EllipsizeEnd]+		(\rend -> cellSetMarkup rend . pangoPrettyBS colors . fst)++	addColumnFS gen "_Server" True (Just (comparing (hostname . snd)))+		(rememberColumn bundle 1)+		cellRendererTextNew+		[cellTextEllipsize := EllipsizeEnd]+		(\rend -> cellSetMarkup rend . pangoPrettyBS colors . hostname . snd)++	treeSortableSetSortColumnId sorted playersSort playersOrder++	on view cursorChanged $ do+		(path, _) <- treeViewGetCursor view+		setCurrent False . snd =<< getElementPath gen path++	on view rowActivated $ \path _ -> do+		setCurrent True . snd =<< getElementPath gen path++	return gen+++playerUpdateOne :: PlayerStore -> GameServer -> IO ()+playerUpdateOne raw gs = do+	lst <- listStoreToList raw+	let oldplayers = [ i | (i, (_, gs')) <- zip [0::Int ..] lst, address gs == address gs']+	let newplayers = map (\a -> (name a, gs)) (players gs)+	foldPlayers newplayers oldplayers+	where+	foldPlayers (n:ns) (i:os) = listStoreSetValue raw i n >> foldPlayers ns os+	foldPlayers []     (i:os) = listStoreRemove raw i     >> foldPlayers [] os+	foldPlayers (n:ns) []     = listStoreAppend raw n     >> foldPlayers ns []+	foldPlayers []     []     = return ()+++rememberColumn :: Bundle -> Int -> TreeViewColumn -> IO ()+rememberColumn Bundle{..} n col = do+	order <- treeViewColumnGetSortOrder col+	current <- takeMVar mconfig+	let new = current {playersSort = n, playersOrder = order}+	putMVar mconfig new+	configToFile parent new

@@ -1,24 +1,47 @@ module GtkExts ( 	EntryIconPosition(..) 	, entrySetIconFromStock+	, cellSetText+	, cellSetMarkup ) 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+import Data.ByteString.Char8  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)+	withForeignPtr arg1 $ \argPtr1 ->+	withUTFString stockId $ \stockIdPtr ->+	gtk_entry_set_icon_from_stock argPtr1 arg2 stockIdPtr+	where+	Entry arg1	= toEntry entry+	arg2		= (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 ()+foreign import ccall unsafe "gtk_entry_set_icon_from_stock"+	gtk_entry_set_icon_from_stock :: Ptr Entry -> CInt -> CString -> IO ()+++cellSetText :: CellRendererText -> ByteString -> IO ()+cellSetText (CellRendererText obj) text =+	withForeignPtr obj $ \wPtr ->+	useAsCString text $ \textPtr ->+	g_object_set wPtr prop_text textPtr nullPtr++cellSetMarkup :: CellRendererText -> ByteString -> IO ()+cellSetMarkup (CellRendererText obj) text =+	withForeignPtr obj $ \wPtr ->+	useAsCString text $ \textPtr ->+	g_object_set wPtr prop_markup textPtr nullPtr++prop_text, prop_markup :: CString+prop_text = unsafePerformIO $ newCString "text"+prop_markup = unsafePerformIO $ newCString "markup"++foreign import ccall unsafe "g_object_set"+	g_object_set :: Ptr CellRendererText -> CString -> CString -> Ptr () -> IO ()

@@ -1,178 +1,148 @@ module GtkUtils where import Graphics.UI.Gtk-import Control.Monad +import Control.Applicative+import Data.Maybe+import Monad2+import Data.ByteString (ByteString) -whenJust :: Monad m => Maybe a -> (a -> m ()) -> m ()-whenJust x f = case x of-	Nothing	-> return ()-	Just a	-> f a -	-			 scrollIt, scrollItV :: WidgetClass widget => widget -> PolicyType -> PolicyType -> IO ScrolledWindow scrollIt widget pol1 pol2 = do 	scroll <- scrolledWindowNew Nothing Nothing 	scrolledWindowSetPolicy scroll pol1 pol2 	containerAdd scroll widget 	return scroll-	+ scrollItV widget pol1 pol2 = do 	scroll <- scrolledWindowNew Nothing Nothing 	scrolledWindowSetPolicy scroll pol1 pol2 	scrolledWindowAddWithViewport scroll widget-	Just vp <- binGetChild scroll+	vp <- binGetChild scroll+	whenJust vp $ \vp2 ->+		set (castToViewport vp2) [ viewportShadowType := ShadowNone ] 	set scroll [ scrolledWindowShadowType := ShadowNone ]-	set (castToViewport vp) [ viewportShadowType := ShadowNone ] 	return scroll-	 -simpleListView :: [(String, Bool, a -> String)] -> IO (ListStore a, TreeView)-simpleListView headers = do-	model <- listStoreNew []-	view <- treeViewNewWithModel model-	select <- treeViewGetSelection view-	treeSelectionSetMode select SelectionNone-	addColumns model view $-		map (\(title, isName, f) -> (title, if isName then 0 else 1, isName, isName, isName, f)) headers-	return (model, view)-	-	 -newLabeledFrame :: String -> IO Frame-newLabeledFrame lbl = do-	frame <- frameNew-	frameSetLabel frame lbl-	return frame-	-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-	g (title, align, format, expand, ellipsize, f) = do-		col <- treeViewColumnNew-		set col	[ treeViewColumnTitle := title-			, treeViewColumnExpand := expand ]-		rend <- cellRendererTextNew-		set rend [ cellXAlign := align]-		when ellipsize $-			set rend [ cellTextEllipsizeSet := True, cellTextEllipsize := EllipsizeEnd]-		cellLayoutPackStart col rend True-		cellLayoutSetAttributes col rend model $ \row -> if format-			then [ cellTextMarkup := Just (f row) ]-			else [ cellText := f row ]-		treeViewAppendColumn view col-		-{--addColumnsSort raw model view xs = sequence_ $ zipWith f (iterate (+1) 0) xs where-	f n (title, format, expand, showf,  sortf) = do-		col <- treeViewColumnNew-		set col	[ treeViewColumnTitle := title-			, treeViewColumnExpand := expand ]-		rend <- cellRendererTextNew-		cellLayoutPackStart col rend True-		cellLayoutSetAttributeFunc col rend model $ \iter -> do-			cIter	<- treeModelSortConvertIterToChildIter model iter-			item	<- treeModelGetRow raw cIter-			set rend $ if format -				then [ cellTextMarkup := Just (showf item) ]-				else [ cellText := showf item ]-		treeViewAppendColumn view col-		case sortf of-			Nothing	-> return ()-			Just g	-> do-				col `treeViewColumnSetSortColumnId` n-				treeSortableSetSortFunc model n (xort raw g)--}-addColumnsFilter :: (TreeViewClass self1, TreeModelFilterClass self, TreeModelClass self, TypedTreeModelClass model) =>-	model t -> self -> self1 -> [(String, Bool, t -> String)] -> IO ()-addColumnsFilter raw model view xs = mapM_ f xs where-	f (title, expand, showf) = do-		col <- treeViewColumnNew-		set col	[ treeViewColumnTitle := title-			, treeViewColumnExpand := expand ]-		rend <- cellRendererTextNew-		when expand $-			set rend [ cellTextEllipsize := EllipsizeEnd]-		cellLayoutPackStart col rend True-		cellLayoutSetAttributeFunc col rend model $ \iter -> do-			cIter	<- treeModelFilterConvertIterToChildIter model iter-			item	<- treeModelGetRow raw cIter-			set rend [ cellTextMarkup := Just (showf item) ]-		treeViewAppendColumn view col+class GeneralTreeView c where+	getElementPath	:: TreeModelClass (a b) => c a b -> [Int] -> IO b+	getElementIter	:: TreeModelClass (a b) => c a b -> TreeIter -> IO b+	getStore	:: TreeModelClass (a b) => c a b -> a b+	getView		:: c a b -> TreeView -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 -> Int -> SortType-	-> [(String, Bool, RendType t, Maybe (t -> t -> Ordering))]++instance GeneralTreeView GenSimple where+	getView (GenSimple _ view)		= view+	getElementIter (GenSimple store _)	= treeModelGetRow store+	getElementPath (GenSimple store _) path	= treeModelGetRow store =<< getIterUnsafe store path+	getStore (GenSimple store _)		= store+++instance GeneralTreeView GenFilterSort where+	getStore (GenFilterSort store _ _ _)	= store+	getView (GenFilterSort _ _ _ view)	= view+	getElementPath g@(GenFilterSort _ _ sorted _) path = getElementIter g =<< getIterUnsafe sorted path+	getElementIter (GenFilterSort store filtered sorted _) it =+		treeModelSortConvertIterToChildIter sorted it >>=+		treeModelFilterConvertIterToChildIter filtered >>=+		treeModelGetRow store++data GenCellRend i	= RendText2 ByteString (i -> [AttrOp CellRendererText])+			| RendMarkup ByteString (i -> [AttrOp CellRendererText])+			| RendPixbuf2 (i -> [AttrOp CellRendererPixbuf])++data GenSimple store a where+	GenSimple	:: (TypedTreeModelClass store, TreeModelClass (store a))+			=> !(store a)+			-> !TreeView+			-> GenSimple store a+data GenFilterSort store a where+	GenFilterSort	:: ( TreeModelClass (store a), TypedTreeModelClass store+			   , TreeModelClass filter, TreeModelFilterClass filter+			   , TreeModelClass sort, TreeModelSortClass sort, TreeSortableClass sort)+			=> !(store a)+			-> !filter+			-> !sort+			-> !TreeView+			-> GenFilterSort store a++newGenSimple :: (TypedTreeModelClass store, TreeModelClass (store a))+             => store a+             -> IO (GenSimple store a)+newGenSimple store = do+	view	<- treeViewNewWithModel store+	return (GenSimple store view)++newGenFilterSort :: (TypedTreeModelClass store, TreeModelClass (store a))+             => store a+             -> IO (GenFilterSort store a)+newGenFilterSort  store = do+	filtered	<- treeModelFilterNew store []+	sorted		<- treeModelSortNewWithModel filtered+	view		<- treeViewNewWithModel sorted+	treeSortableSetDefaultSortFunc sorted Nothing+	return (GenFilterSort store filtered sorted view)++addColumn :: GenSimple a e -> String -> Bool -> [AttrOp CellRendererText] -> (CellRendererText -> e -> IO ()) -> IO Int+addColumn gen@(GenSimple store view) title expand rendOpts f = do+	col <- treeViewColumnNew+	set col	[ treeViewColumnTitle := title+		, treeViewColumnExpand := expand ]+	rend <- cellRendererTextNew+	set rend rendOpts+	set rend [cellTextEllipsize := EllipsizeEnd]+	cellLayoutPackStart col rend True+	cellLayoutSetAttributeFunc col rend store $ \iter -> do+		item <- getElementIter gen iter+		f rend item+	treeViewAppendColumn view col++addColumnFS :: CellRendererClass rend+	=> GenFilterSort a e+	-> String+	-> Bool+	-> Maybe (e -> e -> Ordering)+	-> (TreeViewColumn -> IO ())+	-> IO rend+	-> [AttrOp rend]+	-> (rend -> e -> IO ()) 	-> IO ()-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 ]-		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 ()-			Just g	-> do-				col `treeViewColumnSetSortColumnId` n-				treeSortableSetSortFunc sorted n $ \it1 it2 -> do-					rit1	<- treeModelFilterConvertIterToChildIter filtered it1-					rit2	<- treeModelFilterConvertIterToChildIter filtered it2-					xort raw g 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+addColumnFS gen@(GenFilterSort store filtered sorted view) title expand sortf action mkRend rendOpts f = do+	col <- treeViewColumnNew+	set col	[ treeViewColumnTitle := title+		, treeViewColumnExpand := expand ]+	afterColClicked col (action col)+	rend <- mkRend+	set rend rendOpts+	cellLayoutPackStart col rend True+	cellLayoutSetAttributeFunc col rend sorted $ \iter -> do+		item <- getElementIter gen iter+		f rend item -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+	n <- pred <$> treeViewAppendColumn view col+	whenJust sortf $ \g -> do+		treeViewColumnSetSortColumnId col n+		treeSortableSetSortFunc sorted n $ \it1 it2 -> do+			rit1 <- treeModelFilterConvertIterToChildIter filtered it1+			rit2 <- treeModelFilterConvertIterToChildIter filtered it2+			g <$> treeModelGetRow store rit1 <*> treeModelGetRow store rit2++++getIterUnsafe :: TreeModelClass self => self -> TreePath -> IO TreeIter+getIterUnsafe model path =+	fromMaybe (error "getElement: Imposssible error") <$> treeModelGetIter model path+++gtkPopup :: MessageType -> Window -> String -> IO ()+gtkPopup what win str = do 	a <- messageDialogNew Nothing [DialogDestroyWithParent, DialogModal] 		what ButtonsOk str-	set a [ windowWindowPosition := WinPosCenter]+	windowSetPosition a WinPosCenterOnParent+	windowSetTransientFor a win 	dialogRun a 	widgetDestroy a -gtkWarn, gtkError :: String -> IO ()+gtkWarn, gtkError :: Window -> String  -> IO () gtkWarn = gtkPopup MessageWarning gtkError = gtkPopup MessageError--xort :: TypedTreeModelClass model => model t -> (t -> t -> b) -> TreeIter -> TreeIter -> IO b-xort model g it1 it2 = do-a <- treeModelGetRow model it1 -b <- treeModelGetRow model  it2-return $ g a b 

@@ -0,0 +1,64 @@+module IndividualServerSettings (+	ServerArg(..), ServerSettings+	, getSettings, putSettings, fromFile, toFile+) where+import Control.DeepSeq+import Network.Socket+import Data.List+import Data.Maybe+import Data.Map (Map)+import qualified Data.Map as M+import Network.Tremulous.SocketExtensions+import NumberSerializer++import Constants+import Exception2+import List2+++data ServerArg = ServerArg+	{ serverPass+	, serverRcon+	, serverName		:: !String+	, serverFavorite	:: !Bool+	}++instance NFData ServerArg where+	rnf (ServerArg a b c _) = rnf a `seq` rnf b `seq` rnf c++type ServerSettings = Map SockAddr ServerArg++configFile :: IO FilePath+configFile = inConfDir "serversettings"++getSettings :: SockAddr -> ServerSettings -> ServerArg+getSettings = M.findWithDefault (ServerArg "" "" "" False)++putSettings :: SockAddr -> ServerArg -> ServerSettings -> ServerSettings+putSettings = M.insert++fromFile :: IO ServerSettings+fromFile = handleIOWith M.empty $ do+	cont <- readFile =<< configFile+	return  $! strict (parse cont)+	where strict a = deepseq a a+++toFile :: ServerSettings -> IO Bool+toFile settings = tryIO $ do+	fx <- configFile+	writeFile fx $ unlines $ map f $ M.toList settings+	where f ((SockAddrInet (PortNum port) ip), ServerArg a b c d) = intercalate "\t"+		[ intToHex 8 (ntohl ip)+		, intToHex 4 (ntohs port)+		, a, b, c+		, if d then "f" else "" ]+	      f _ = ""++parse :: String -> ServerSettings+parse = M.fromList . mapMaybe (f . split '\t') . lines+	where+	f (ip:port:pass:rcon:name:opts:_) = Just (addr, ServerArg pass rcon name fav)+		where addr = SockAddrInet (PortNum (htons (hexToInt port))) (htonl (hexToInt ip))+		      fav  = 'f' `elem` opts+	f _  = Nothing

@@ -3,7 +3,7 @@   newInfobox :: String -> IO (VBox, Label, Label)-newInfobox what= do+newInfobox what = do 	lst <- mapM (labelNew . Just) 		["Showing", "0", " out of", "0", ' ' : what] 		

@@ -1,4 +1,4 @@-module List2 (stripw, intmean, replace) where+module List2 (stripw, intmean, replace, mread, split, breakDrop) where import Prelude hiding (foldr, foldl, foldr1, foldl1) import Data.Char import Data.Foldable@@ -10,7 +10,7 @@ dropWhileRev p = foldr (\x xs -> if p x && null xs then [] else x:xs) []  intmean :: (Integral i, Foldable f) => f i -> i-intmean l = if len == 0 then 0 else lsum `div` len where+intmean l = if len == 0 then 0 else lsum `quot` len where 	(len, lsum) = foldl' (\(!n, !s) elm -> (n+1, s+elm)) (0, 0) l  replace :: (a -> Bool) -> a -> [a] -> [a]@@ -18,3 +18,21 @@ 	| f x		= y : xs 	| otherwise	= x : replace f y xs replace _ _ []		= []++mread :: (Read a) => String -> Maybe a+mread x = case reads x of+	[(a, _)]	-> Just a+	_		-> Nothing++split :: Eq a => a -> [a] -> [[a]]+split _ [] = []+split d s  = case break (== d) s of+	(w, s') -> w : case s' of+		[_]   -> [[]]+		_:s'' -> split d s''++		[]    -> []++breakDrop :: (a -> Bool) -> [a] -> ([a], [a])+breakDrop f xs = let (a, b) = break f xs+	in (a, dropWhile f b)

@@ -0,0 +1,24 @@+module Monad2 where+import Control.Monad+import Network.Socket+import Control.Exception+import Control.Applicative+import Data.Maybe++whileTrue :: Monad m => m Bool -> m ()+whileTrue f = f >>= \t -> when t (whileTrue f)++whenJust :: Monad m => Maybe a -> (a -> m ()) -> m ()+whenJust x f = case x of+	Nothing	-> return ()+	Just a	-> f a++whenM :: Monad m => m Bool -> m () -> m ()+whenM c m = c >>= \t -> if t then m else return ()++unlessM :: Monad m => m Bool -> m () -> m ()+unlessM c m = c >>= \t -> if not t then m else return ()++getDNS :: String -> String -> IO (Maybe SockAddr)+getDNS host port = handle (\(_ :: IOException) -> return Nothing) $+	fmap addrAddress . listToMaybe <$> getAddrInfo Nothing (Just host) (Just port)

@@ -0,0 +1,25 @@+module NumberSerializer where+import Data.Bits+import Network.Tremulous.SocketExtensions+import Network.Socket++intToHex :: (Integral i, Bits i) => Int -> i -> String+intToHex = go [] where+	go b 0 _   = b+	go b n int = go (toDigit (int .&. 0xF) : b) (n-1) (int `shiftR` 4)+	toDigit i | i <= 9    = conv (i + 0x30)+	          | otherwise = conv (i + 0x61-0xa)+	conv = toEnum . fromIntegral++hexToInt :: (Integral i, Bits i) => String -> i+hexToInt = go 0 where+	go b []     = b+	go b (x:xs) = go ((b `shiftL` 4) .|. toInt x) xs+	toInt c | c' <= 0x39 = c' - 0x30+	        | otherwise  = c' - (0x61-0xa)+	        where c' = conv c+	conv = fromIntegral . fromEnum+++stringToSockAddr :: String -> String -> SockAddr+stringToSockAddr ip port = SockAddrInet (PortNum (htons (hexToInt port))) (htonl (hexToInt ip))

@@ -0,0 +1,83 @@+module OnlineClans (newOnlineClans) where+import Graphics.UI.Gtk++import Data.Monoid+import Data.Ord+import Data.Tree+import Data.List (sortBy)+import Control.Concurrent+import Network.Tremulous.NameInsensitive+import qualified Network.Tremulous.Protocol as P+import Network.Tremulous.Util+import qualified Data.ByteString.Char8 as B++import ClanFetcher+import Types+import Config+import GtkUtils+import GtkExts+import TremFormatting++newOnlineClans :: Bundle-> SetCurrent -> IO (ScrolledWindow, ClanPolledHook)+newOnlineClans Bundle{..} setServer = do+	Config {colors} <- readMVar mconfig++	gen@(GenSimple raw view) <- newGenSimple =<< treeStoreNew []++	addColumn gen "Name" True [cellTextEllipsize := EllipsizeEnd] $ \rend ->+		cellSetMarkup rend . showName colors+	addColumn gen "Server" True [cellTextEllipsize := EllipsizeEnd] $ \rend ->+		cellSetMarkup rend . showServer colors++	let updateF clans P.PollResult{..} = do+		let players = buildTree $ sortByPlayers $+			associatePlayerToClans (makePlayerNameList polled) clans+		treeStoreClear raw+		treeViewColumnsAutosize view+		mapM_ (treeStoreInsertTree raw [] 0) players+		treeViewExpandAll view++	on view cursorChanged $ do+		(path, _)	<- treeViewGetCursor view+		item		<- getElementPath gen path+		case item of+			Left _ -> return ()+			Right (_, gs) -> setServer False gs++	on view rowActivated $ \path _ -> do+		item		<- getElementPath gen path+		case item of+			Left _ -> return ()+			Right (_, gs) -> setServer True gs++	scroll <- scrollIt view PolicyAutomatic PolicyAutomatic++	return (scroll, updateF)+	where+	showName colors c =  case c of+		Left Clan{..}		-> B.concat ["<b>", htmlEscapeBS $ original name, "</b>"]+		Right (name, _)		-> pangoPrettyBS colors name++	showServer colors c =  case c of+		Left _ -> ""+		Right (_, P.GameServer{hostname}) -> pangoPrettyBS colors hostname+++type PlayerList = [(TI, 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 . fst++buildTree :: [(Clan, PlayerList)] -> OnlineView+buildTree = filter notEmpty . foldr f [] where+	f (clan, pls) xs = Node (Left clan) (map rightNode pls) : xs+	rightNode x = Node (Right x) []+	notEmpty (Node _ [])	= False+	notEmpty _		= True++sortByPlayers :: [(Clan, [b])] -> [(Clan, [b])]+sortByPlayers = sortBy $ comparing (length . snd) `mappend` flip (comparing (name . fst))

@@ -1,8 +1,9 @@-module Preferences where+{-# LANGUAGE CPP #-}+module Preferences (newPreferences) where import Graphics.UI.Gtk+ import Control.Monad import Control.Applicative hiding (empty)-import Control.Concurrent.STM import Data.Char import Data.Array import Text.Printf@@ -10,117 +11,117 @@ import System.FilePath  import Types-import Config+import qualified Config as C import Constants import GtkUtils+import Monad2 import TremFormatting +#define _CONNECT(WID, SIG, GET, SET) on WID SIG (do {new <- get WID GET; update (\x -> x { SET = new})})+#define _CONNECT_WITH(WID, SIG, GET, SET, F) on WID SIG (do {new <- get WID GET; update (\x -> x { SET = F new})})  newPreferences :: Bundle -> IO ScrolledWindow newPreferences Bundle{..} = do+	let update f = do+		new <- modifyMVar mconfig $ \old -> do+			let new = f old+			return (new, new)+		C.configToFile parent new+ 	-- Default filters-	(tbl, [filterBrowser', filterPlayers'], filterEmpty') <--		configTable ["_Browser:", "Find _players:"]-	filters <- newLabeledFrame "Default filters"-	set filters [ containerChild := tbl]+	(  tbl+	 , [filterBrowser, filterPlayers]+	 , filterEmpty+	 ) <- configTable+		[ "_Browser:"+		, "_Find players:"+		]+	filters <- framed "Default filters" tbl  	-- Tremulous path-	(pathstbl, [tremPath', tremGppPath']) <- pathTable parent ["_Tremulous 1.1:", "Tremulous _GPP:"]-	paths <- newLabeledFrame "Tremulous path or command"-	set paths [ containerChild := pathstbl]+	(pathstbl, [tremPath, tremGppPath]) <- pathTable parent ["_Tremulous 1.1:", "Tremulous _GPP:"]+	paths <- framed "Tremulous path or command" pathstbl  	-- Startup-	startupMaster	<- checkButtonNewWithMnemonic "_Refresh all servers"-	startupClan	<- checkButtonNewWithMnemonic "_Sync clan list"-	startupGeometry	<- checkButtonNewWithMnemonic "Restore _window geometry from previous session"-	-	(startup, startupBox) <- framedVBox ("On startup")-	boxPackStartDefaults startupBox startupMaster	-	boxPackStartDefaults startupBox startupClan-	boxPackStartDefaults startupBox startupGeometry-			+	autoClan	<- checkButtonNewWithMnemonic "_Sync clan list"+	autoGeometry	<- checkButtonNewWithMnemonic "Restore _window geometry from previous session"+	startupBox <- vBoxNew False 0+	boxPackStartDefaults startupBox autoClan+	boxPackStartDefaults startupBox autoGeometry+	startup <- framed "On startup" startupBox -	-- Colors+	--Refresh mode+	rb1 <- radioButtonNewWithMnemonic "_Once at startup"+	rb2 <- radioButtonNewWithMnemonicFromWidget rb1 "_Periodically each"+	rb3 <- radioButtonNewWithMnemonicFromWidget rb1 "_Manually"+	autoDelay <- spinButtonNewWithRange 0 3600 1+	seconds <- labelNew (Just "s") -	(colorTbl, colorList)	<- numberedColors -	(colors', colorBox)	<- framedVBox "Color theme"-	colorWarning		<- labelNew (Just "Note: Requires a restart to take effect")-	+	delaybox <- hBoxNew False spacing+	boxPackStart delaybox autoDelay PackNatural 0+	boxPackStart delaybox seconds PackNatural 0++	perbox <- hBoxNew False spacingBig+	boxPackStart perbox rb2 PackNatural 0+	boxPackStart perbox delaybox PackNatural 0++	rbBox <- vBoxNew False 0+	boxPackStartDefaults rbBox rb1+	boxPackStartDefaults rbBox perbox+	boxPackStartDefaults rbBox rb3+	refreshmode <- framed "Refresh all" rbBox++	-- Colors+	(colorTbl, colorList) <- numberedColors+	colorWarning <- labelNew (Just "Note: Requires a restart to take effect") 	miscSetAlignment colorWarning 0 0+	colorBox <- vBoxNew False spacing 	boxPackStart colorBox colorTbl PackNatural 0 	boxPackStart colorBox colorWarning PackNatural 0+	colors' <- framed "Color theme" colorBox   	-- Internals-	(itbl, [itimeout, iresend, ibuf]) <- mkInternals -	(internals, ibox) <- framedVBox "Polling Internals"+	(itbl, [packetTimeout', packetDuplication', throughputDelay']) <- mkInternals 	ilbl <- labelNew $ Just "Tip: Hover the cursor over each option for a description" 	miscSetAlignment ilbl 0 0-	--labelSetLineWrap ilbl True+	ibox <- vBoxNew False spacing 	boxPackStart ibox itbl PackNatural 0 	boxPackStart ibox ilbl PackNatural 0 --	-- Apply-	apply	<- buttonNewFromStock stockApply-	bbox	<- hBoxNew False 0-	boxPackStartDefaults bbox apply-	balign	<- alignmentNew 0.5 1 0 0-	set balign [ containerChild := bbox ]+	internals <- framed "Polling Internals" ibox -	on apply buttonActivated $ do-		filterBrowser	<- get filterBrowser' entryText-		filterPlayers	<- get filterPlayers' entryText-		filterEmpty	<- get filterEmpty' toggleButtonActive-		tremPath	<- get tremPath' entryText-		tremGppPath	<- get tremGppPath' entryText-		autoMaster	<- get startupMaster toggleButtonActive-		autoClan	<- get startupClan toggleButtonActive-		autoGeometry	<- get startupGeometry toggleButtonActive-		packetTimeout	<- (*1000) <$> spinButtonGetValueAsInt itimeout-		packetDuplication	<- spinButtonGetValueAsInt iresend-		throughputDelay	<- (*1000) <$> spinButtonGetValueAsInt ibuf-		-		rawcolors	<- forM colorList $ \(colb, cb) -> do-					bool <- get cb toggleButtonActive-					(if bool then TFColor else TFNone)-						 . colorToHex <$> colorButtonGetColor colb-		old		<- atomically $ takeTMVar mconfig-		let new		= old {filterBrowser, filterPlayers, autoMaster-				, autoClan, autoGeometry, tremPath, tremGppPath-				, colors = makeColorsFromList rawcolors-				, delays = Delay{..}, filterEmpty}-		atomically $ putTMVar mconfig new-		configToFile new-		return ()-	 	-- Main box--	box <- vBoxNew False spacing-	set box [ containerBorderWidth := spacingBig ]+	box <- vBoxNew False spacingHuge+	containerSetBorderWidth box spacing 	boxPackStart box filters PackNatural 0 	boxPackStart box paths PackNatural 0+	boxPackStart box refreshmode PackNatural 0 	boxPackStart box startup PackNatural 0 	boxPackStart box colors' PackNatural 0 	boxPackStart box internals PackNatural 0-	boxPackStart box balign PackGrow 0   	-- Set values from Config 	let updateF = do-		Config {..} 		<- atomically $ readTMVar mconfig-		set filterBrowser'	[ entryText := filterBrowser ]-		set filterPlayers'	[ entryText := filterPlayers ]-		set filterEmpty'	[ toggleButtonActive := filterEmpty]-		set tremPath'		[ entryText := tremPath ]-		set tremGppPath'	[ entryText := tremGppPath ]-		set startupMaster	[ toggleButtonActive := autoMaster ]-		set startupClan		[ toggleButtonActive := autoClan ]-		set startupGeometry	[ toggleButtonActive := autoGeometry ]-		set itimeout		[ spinButtonValue := fromIntegral (packetTimeout delays `div` 1000) ]-		set iresend		[ spinButtonValue := fromIntegral (packetDuplication delays) ]-		set ibuf		[ spinButtonValue := fromIntegral (throughputDelay delays `div` 1000) ]-		sequence_ $ zipWith f colorList (elems colors)+		c <- readMVar mconfig+		let Delay{..} = C.delays c+		set filterBrowser	[ entryText := C.filterBrowser c ]+		set filterPlayers	[ entryText := C.filterPlayers c ]+		set filterEmpty		[ toggleButtonActive := C.filterEmpty c]+		set tremPath		[ entryText := C.tremPath c ]+		set tremGppPath		[ entryText := C.tremGppPath c]+		set autoClan		[ toggleButtonActive := C.autoClan c]+		set autoGeometry	[ toggleButtonActive := C.autoGeometry c]+		set autoDelay		[ spinButtonValue := fromIntegral (C.autoDelay c `quot` 1000000) ]+		set packetTimeout'	[ spinButtonValue := fromIntegral (packetTimeout `quot` 1000) ]+		set packetDuplication'	[ spinButtonValue := fromIntegral packetDuplication ]+		set throughputDelay'	[ spinButtonValue := fromIntegral (throughputDelay `quot` 1000) ]+		set rb1			[ toggleButtonActive := C.refreshMode c == C.Startup ]+		set rb2			[ toggleButtonActive := C.refreshMode c == C.Auto ]+		set rb3			[ toggleButtonActive := C.refreshMode c == C.Manual ]++		zipWithM_ f colorList (elems (C.colors c)) 		where	f (a, b) (TFColor c) = do 				colorButtonSetColor a (hexToColor c) 				toggleButtonSetActive b True@@ -129,49 +130,100 @@ 				toggleButtonSetActive b False 				-- Apparently this is needed too 				toggleButtonToggled b+ 	updateF-		++	_CONNECT(filterBrowser, editableChanged, entryText, C.filterBrowser)+	_CONNECT(filterEmpty, toggled, toggleButtonActive, C.filterEmpty)+	_CONNECT(filterPlayers, editableChanged, entryText, C.filterPlayers)++	_CONNECT(tremPath, editableChanged, entryText, C.tremPath)+	_CONNECT(tremGppPath, editableChanged, entryText, C.tremGppPath)++	--_CONNECT(autoMaster, toggled, toggleButtonActive, C.autoMaster)+	_CONNECT(autoClan, toggled, toggleButtonActive, C.autoClan)+	_CONNECT(autoGeometry, toggled, toggleButtonActive, C.autoGeometry)+++	let radiofunc value = update (\x -> x { C.refreshMode = value})++	on rb1 toggled $ do	b <- toggleButtonGetActive rb1+				when b (radiofunc C.Startup)+	on rb2 toggled $ do	b <- toggleButtonGetActive rb2+				when b (radiofunc C.Auto)+	on rb3 toggled $ do	b <- toggleButtonGetActive rb3+				when b (radiofunc C.Manual)++	onValueSpinned autoDelay $ do+		value <- (*1000000) <$> spinButtonGetValueAsInt autoDelay+		update (\x -> x { C.autoDelay = fromIntegral value})++	onValueSpinned packetTimeout' $ do+		packetTimeout <- (*1000) <$> spinButtonGetValueAsInt packetTimeout'+		update (\x -> let delays = C.delays x in x {C.delays = delays {packetTimeout}})++	onValueSpinned packetDuplication' $ do+		packetDuplication <- spinButtonGetValueAsInt packetDuplication'+		update (\x -> let delays = C.delays x in x {C.delays = delays {packetDuplication}})++	onValueSpinned throughputDelay' $ do+		throughputDelay <- (*1000) <$> spinButtonGetValueAsInt throughputDelay'+		update (\x -> let delays = C.delays x in x {C.delays = delays {throughputDelay}})++	let updateColors = do+		rawcolors <- forM colorList $ \(colb, cb) -> do+			bool <- get cb toggleButtonActive+			(if bool then TFColor else TFNone)+				 . colorToHex <$> colorButtonGetColor colb+		update $ \x -> x {C.colors = C.makeColorsFromList rawcolors}++	forM colorList $ \(colb, cb) -> do+		on cb toggled updateColors+		afterColorSet colb updateColors+ 	scrollItV box PolicyNever PolicyAutomatic  configTable :: [String] -> IO (Table, [Entry], CheckButton) configTable ys = do-	tbl <- tableNew 0 0 False+	tbl <- paddedTableNew 	empty <- checkButtonNewWithMnemonic "_empty" 	let easyAttach pos lbl  = do 		a <- labelNewWithMnemonic lbl-		b <- entryNew-		set a [ labelMnemonicWidget := b ]++		ent <- entryNew+		b <- hBoxNew False spacingHalf+		boxPackStart b ent PackGrow 0+		when (pos == 0) $+			boxPackStart b empty PackNatural 0++		set a [ labelMnemonicWidget := ent ] 		miscSetAlignment a 0 0.5-		tableAttach tbl a 0 1 pos (pos+1) [Fill] [] spacing spacingHalf-		tableAttach tbl b 1 2 pos (pos+1) [Expand, Fill] [] spacing spacingHalf-		when (pos == 0) $ -			tableAttach tbl empty 2 3 pos (pos+1) [Fill] [] spacing spacingHalf-				-		return b-		-	let mkTable xs = mapM (uncurry easyAttach) (zip [0..] xs)-	rt	<- mkTable ys+		tableAttach tbl a 0 1 pos (pos+1) [Fill] [] 0 0+		tableAttach tbl b 1 2 pos (pos+1) [Expand, Fill] [] 0 0++		return ent++	rt <- zipWithM easyAttach [0..] ys 	return (tbl, rt, empty)  pathTable :: Window -> [String] -> IO (Table, [Entry]) pathTable parent ys = do-	tbl <- tableNew 0 0 False+	tbl <- paddedTableNew 	let easyAttach pos lbl  = do 		a <- labelNewWithMnemonic lbl 		(box, ent) <- pathSelectionEntryNew parent 		set a [ labelMnemonicWidget := ent ] 		miscSetAlignment a 0 0.5-		tableAttach tbl a 0 1 pos (pos+1) [Fill] [] spacing spacingHalf-		tableAttach tbl box 1 2 pos (pos+1) [Expand, Fill] [] spacing spacingHalf+		tableAttach tbl a 0 1 pos (pos+1) [Fill] [] 0 0+		tableAttach tbl box 1 2 pos (pos+1) [Expand, Fill] [] 0 0 		return ent-		-	let mkTable xs = mapM (uncurry easyAttach) (zip [0..] xs)-	rt	<- mkTable ys++	rt	<- zipWithM easyAttach [0..] ys 	return (tbl, rt)  mkInternals :: IO (Table, [SpinButton]) mkInternals = do-	tbl <- tableNew 0 0 False+	tbl <- paddedTableNew 	let easyAttach pos (lbl, lblafter, tip)  = do 		a <- labelNewWithMnemonic lbl 		b <- spinButtonNewWithRange 0 10000 1@@ -180,44 +232,50 @@ 			, 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+		tableAttach tbl a 0 1 pos (pos+1) [Fill] [] 0 0+		tableAttach tbl b 1 2 pos (pos+1) [Fill] [] 0 0+		tableAttach tbl c 2 3 pos (pos+1) [Fill] [] 0 0 		return b-		-	let mkTable xs = mapM (uncurry easyAttach) (zip [0..] xs)++	let mkTable = zipWithM easyAttach [0..] 	rt <- mkTable	[ ("Respo_nse Timeout:", "ms", "How long Apelsin should wait before sending a new request to a server possibly not responding") 			, ("Maximum packet _duplication:", "times", "Maximum number of extra requests to send beoynd the initial one if a server does not respond" ) 			, ("Throughput _limit:", "ms", "Should be set as low as possible as long as pings from \"Refresh all servers\" remains the same as \"Refresh current\"") ] 	return (tbl, rt)  -framedVBox :: String -> IO (Frame, VBox)-framedVBox title = do-	box	<- vBoxNew False 0-	frame	<- newLabeledFrame title-	set box [ containerBorderWidth := spacing ]-	set frame	[ containerChild := box ]-	return (frame, box)-	+framed :: ContainerClass w => String -> w -> IO VBox+framed title box = do+	l <- labelNew (Just title)+	miscSetAlignment l 0 0+	labelSetAttributes l [AttrWeight 0 (-1) WeightBold]++	align <- alignmentNew 0.5 0.5 1 1+	alignmentSetPadding align 0 0 spacingBig 0+	containerAdd align box++	vb <- vBoxNew False spacing+	boxPackStart vb l PackNatural 0+	boxPackStart vb align PackNatural 0++	return vb+ numberedColors :: IO (Table, [(ColorButton, CheckButton)]) numberedColors = do-	tbl <- tableNew 0 0 False+	tbl <- paddedTableNew 	let easyAttach pos lbl  = do 		a <- labelNew (Just lbl) 		b <- colorButtonNew 		c <- checkButtonNew-		on c toggled $ do-			bool <- get c toggleButtonActive-			set b [ widgetSensitive := if bool then True else False ]+		on c toggled $+			widgetSetSensitive b =<< toggleButtonGetActive c 		miscSetAlignment a 0.5 0-		tableAttach tbl a pos (pos+1) 0 1 [Fill] [] spacingHalf spacingHalf-		tableAttach tbl b pos (pos+1) 1 2 [Fill] [] spacingHalf spacingHalf-		tableAttach tbl c pos (pos+1) 2 3 [] [] spacingHalf spacingHalf+		tableAttach tbl a pos (pos+1) 0 1 [Fill] [] 0 0+		tableAttach tbl b pos (pos+1) 1 2 [Fill] [] 0 0+		tableAttach tbl c pos (pos+1) 2 3 [] [] 0 0 		return (b, c)-	let mkTable xs = mapM (uncurry easyAttach) (zip (iterate (+1) 0) xs) -	xs <- mkTable ["^0", "^1", "^2", "^3", "^4", "^5", "^6", "^7"]+	xs <- zipWithM easyAttach [0..]  ["^0", "^1", "^2", "^3", "^4", "^5", "^6", "^7"] 	return (tbl, xs)  @@ -225,15 +283,14 @@ pathSelectionEntryNew :: Window -> IO (HBox, Entry) pathSelectionEntryNew parent = do 	box	<- hBoxNew False 0-	img	<- imageNewFromStock stockOpen (IconSizeUser 1) 	button	<- buttonNew-	set button [ buttonImage := img ]+	set button [ buttonImage :=> imageNewFromStock stockOpen (IconSizeUser 1) ] 	ent	<- entryNew  	boxPackStart box ent PackGrow 0 	boxPackStart box button PackNatural 0-	-		++ 	on button buttonActivated $ do 		fc	<- fileChooserDialogNew (Just "Select path") (Just parent) FileChooserActionOpen 			[ (stockCancel, ResponseCancel)@@ -249,17 +306,20 @@ 						set ent [ entryText := path ] 			_-> return () 		widgetDestroy fc-		-	-	return (box, ent)  --- And more fail by gtk to not include something like this by default+	return (box, ent) +paddedTableNew :: IO Table+paddedTableNew = do+	tbl <- tableNew 0 0 False+	set tbl	[ tableRowSpacing	:= spacingHalf+		, tableColumnSpacing	:= spacing ]+	return tbl+ colorToHex :: Color -> String colorToHex (Color a b c) = printf "#%02x%02x%02x" (f a) (f b) (f c)-	where f = (`div` 0x100)-+	where f = (`quot` 0x100)  hexToColor :: String -> Color hexToColor ('#':a:b:c:d:e:g:_)	= Color (f a b) (f c d) (f e g)

@@ -1,37 +0,0 @@-module STM2(-	module Control.Concurrent, module Control.Concurrent.STM-	, tryReadTMVar, withTMVar, clearTMVar, replaceTMVar, modifyTMVar-) where--import Control.Concurrent-import Control.Concurrent.STM-import Control.Monad--tryReadTMVar :: TMVar a -> STM (Maybe a)-tryReadTMVar v = do -	x <- tryTakeTMVar v-	case x of-		Just a	-> putTMVar v a >> return (Just a)-		Nothing	-> return Nothing--withTMVar :: TMVar a -> (a -> IO ()) -> IO ()-withTMVar mvar f = do-	tst <- atomically $ tryReadTMVar mvar-	case tst of-		Nothing	-> return ()-		Just a	-> f a-		-clearTMVar :: TMVar a -> STM ()		-clearTMVar mvar = do-	t <- isEmptyTMVar mvar-	unless t $ do-		takeTMVar mvar-		return ()--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)

@@ -1,95 +1,129 @@-module ServerBrowser where+module ServerBrowser (newServerBrowser, browserUpdateOne) where import Graphics.UI.Gtk-import Control.Concurrent.STM import Data.IORef-import qualified Data.ByteString.Char8 as B import Data.Ord+import Data.Monoid import Network.Tremulous.Protocol+import qualified Network.Tremulous.StrictMaybe as SM import Text.Printf+import qualified Data.ByteString.Char8 as B  import Types import GtkUtils+import GtkExts import FilterBar import InfoBox import TremFormatting import Constants import Config -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 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))-		]+newServerBrowser :: Bundle -> SetCurrent -> IO (VBox, PolledHook)+newServerBrowser bundle@Bundle{..} setServer = do+	Config {..} <- readMVar mconfig+	gen@(GenFilterSort raw filtered sorted view) <- newGenFilterSort browserStore++	addColumnFS gen "_Game" False+		(Just (comparing protocol `mappend` comparing gamemod `mappend` comparing gameping))+		(rememberColumn bundle 0)+		cellRendererTextNew+		[]+		(\rend -> cellSetText rend . showGame)++	addColumnFS gen "_Name" True+		(Just (comparing hostname `mappend` comparing gameping))+		(rememberColumn bundle 1)+		cellRendererTextNew+		[cellTextEllipsize := EllipsizeEnd]+		(\rend -> cellSetMarkup rend . pangoPrettyBS colors . hostname)++	addColumnFS gen "_Map" False+		(Just (comparing mapname `mappend` comparing gameping))+		(rememberColumn bundle 2)+		cellRendererTextNew []+		(\rend -> cellSetText rend . SM.maybe "" (B.take 16 . original) . mapname)++	addColumnFS gen "P_ing" False+		(Just (comparing gameping `mappend` comparing hostname))+		(rememberColumn bundle 3)+		cellRendererTextNew+		[cellXAlign := 1]+		(\rend x -> set rend [cellText := show $ gameping x])++	addColumnFS gen "_Players" False+		(Just (comparing nplayers `mappend` flip (comparing gameping)))+		(rememberColumn bundle 4)+		cellRendererTextNew+		[cellXAlign := 1]+		(\rend x -> set rend [cellText := showPlayers x])+++	treeSortableSetSortColumnId sorted browserSort browserOrder+ 	(infobox, statNow, statTot, statRequested) <- newInfoboxBrowser-	-	(filterbar, current, ent) <- newFilterBar filtered statNow filterBrowser++	(filterbar, current) <- newFilterBar parent filtered statNow filterBrowser 	empty <- checkButtonNewWithMnemonic "_empty" 	set empty [ toggleButtonActive := filterEmpty ] 	boxPackStart filterbar empty PackNatural spacingHalf 	on empty toggled $ do 		treeModelFilterRefilter filtered-		n <- treeModelIterNChildren filtered Nothing-		set statNow [ labelText := show n ]+		labelSetText statNow . show =<< treeModelIterNChildren filtered Nothing   	treeModelFilterSetVisibleFunc filtered $ \iter -> do 		GameServer{..}	<- treeModelGetRow raw iter 		s		<- readIORef current 		showEmpty	<- toggleButtonGetActive empty-		return $ (showEmpty || not (null players)) && (B.null s ||-			smartFilter s [-				  cleanedCase hostname-				, cleanedCase mapname+		return $ (showEmpty || not (null players)) &&+			(smartFilter s+				[ cleanedCase hostname+				, SM.maybe "" cleanedCase mapname+				, SM.maybe "" cleanedCase version 				, proto2string protocol-				, maybe "" cleanedCase gamemod+				, SM.maybe "" cleanedCase gamemod 				])-			+ 	on view cursorChanged $ do 		(path, _) <- treeViewGetCursor view-		setServer False =<< getElementFS raw sorted filtered path+		setServer False =<< getElementPath gen path  	on view rowActivated $ \path _ ->-		setServer True =<< getElementFS raw sorted filtered path-		+		setServer True =<< getElementPath gen path+ 	scrollview <- scrolledWindowNew Nothing Nothing 	scrolledWindowSetPolicy scrollview PolicyNever PolicyAlways 	containerAdd scrollview view-	+ 	let updateF PollResult{..} = do 		listStoreClear raw 		treeViewColumnsAutosize view 		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 ]-		+		labelSetText statTot       $ show serversResponded+		labelSetText statRequested $ show (serversRequested - serversResponded)+		labelSetText statNow . show =<< treeModelIterNChildren filtered Nothing+ 	box <- vBoxNew False 0 	boxPackStart box filterbar PackNatural spacing 	boxPackStart box scrollview PackGrow 0 	boxPackStart box infobox PackNatural 0-	-	return (box, updateF, ent)++	return (box, updateF) 	where-	showGame GameServer{..} = proto2string protocol ++ maybe "" (("-"++) . htmlEscape . unpackorig) gamemod+	showGame GameServer{..} = B.concat (proto2string protocol : SM.maybe [] ((\x -> ["-",x]) . original) 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 ]++browserUpdateOne :: BrowserStore -> GameServer -> IO ()+browserUpdateOne raw gs = treeModelForeach raw $ \iter -> do+	let i = listStoreIterToIndex iter+	e <- listStoreGetValue raw i+	if address e == address gs+		then listStoreSetValue raw i gs >> return True+		else return False++rememberColumn :: Bundle -> Int -> TreeViewColumn -> IO ()+rememberColumn Bundle{..} n col = do+	order <- treeViewColumnGetSortOrder col+	current <- takeMVar mconfig+	let new = current {browserSort = n, browserOrder = order}+	putMVar mconfig new+	configToFile parent new

@@ -5,75 +5,87 @@ import Control.Applicative import Control.Monad hiding (join) import Control.Exception+import Control.Concurrent import Data.Ord-import Data.List (sortBy, findIndex)+import Data.ByteString.Char8 (unpack)+import Data.List (sortBy) import System.Process import System.FilePath  import Network.Tremulous.Protocol+import qualified Network.Tremulous.StrictMaybe as SM import Network.Tremulous.Polling import Network.Tremulous.Util +import ConcurrentUtil import Types-import STM2+import Exception2 import List2+import Monad2 import TremFormatting import GtkUtils+import GtkExts import Constants import Config+import IndividualServerSettings+import SettingsDialog+import FindPlayers+import ServerBrowser+import AutoRefresh -newServerInfo :: Bundle -> TMVar (PolledHook, ClanPolledHook) -> IO (VBox, PolledHook, SetCurrent)+newServerInfo :: Bundle -> MVar (PolledHook, ClanPolledHook) -> IO (VBox, PolledHook, SetCurrent) newServerInfo Bundle{..} mupdate = do-	Config {colors} <- atomically $ readTMVar mconfig-	current		<- atomically newEmptyTMVar-	running		<- atomically newEmptyTMVar-	+	Config {colors} <- readMVar mconfig+	current		<- newEmptyMVar+	running		<- newEmptyMVar+ 	-- Host name-	hostnamex <- labelNew Nothing+	hostnamex <- labelNew (Just "Server") 	set hostnamex [ 		  labelWrap		:= True 		, labelJustify		:= JustifyCenter 		, labelSelectable	:= True 		, labelUseMarkup	:= True-		, labelLabel		:= formatHostname "Server"-		-- failgtk exception..-		--, labelWrapMode := WrapPartialWords+		, labelAttributes 	:= [AttrWeight 0 (-1) WeightBold, AttrScale 0 (-1) 1.2] 		]-	+	labelSetLineWrapMode hostnamex WrapPartialWords+ 	-- Pretty CVar table-	tbl <- tableNew 5 2 True+	tbl <- tableNew 0 0 True 	set tbl [ tableRowSpacing := spacing-		, tableColumnSpacing := spacingBig ]+		, tableColumnSpacing := spacing ] 	let easyAttach pos lbl  = do 		a <- labelNew (Just lbl) 		b <- labelNew Nothing+		let h = 0x8888+		labelSetAttributes a [AttrForeground 0 (-1) (Color h h h)]+ 		set a [ miscXalign := 1 ]-		set b [ miscXalign := 0 ]+		set b [ miscXalign := 0, labelSelectable := True] 		tableAttachDefaults tbl a 0 1 pos (pos+1) 		tableAttachDefaults tbl b 1 2 pos (pos+1) 		return b-		+ 	let mkTable = zipWithM easyAttach [0..]-	info <- mkTable ["IP:Port", "Game (mod)", "Map", "Timelimit (SD)"-			, "Slots (+private)", "Ping (server average)"]-	set (head info) [ labelSelectable := True ]-	+	info <- mkTable ["Address", "Game", "Map", "Timelimit / SD"+			, "Slots (+private)", "Ping / Average"]+	versionLabel <- labelNew Nothing+	bools <- labelNew Nothing++	labelSetSelectable versionLabel True+	labelSetSelectable bools True+ 	-- Players 	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) ]-	(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"-	-	++	GenSimple amodel aview <- playerView colors "Aliens" True+	GenSimple hmodel hview <- playerView colors "Humans" True+	GenSimple smodel sview <- playerView colors "Spectators" False+	-- For servers not giving the P CVar:+	GenSimple umodel uview <- playerView colors "Players" True++ 	ascroll <- scrollIt aview PolicyNever PolicyAutomatic 	hscroll <- scrollIt hview PolicyNever PolicyAutomatic 	uscroll	<- scrollIt uview PolicyNever PolicyAutomatic@@ -86,165 +98,235 @@ 	boxPackStart allplayers alienshumans PackGrow 0 	boxPackStart allplayers sscroll PackNatural 0 +	Requisition _ natural	<- widgetSizeRequest sscroll+	on allplayers sizeAllocate $ \(Rectangle _ _ _ h') -> do+		let h = h' - spacing+		Requisition _ sReq	<- widgetSizeRequest sview+		Requisition _ aReq	<- widgetSizeRequest aview+		Requisition _ hReq	<- widgetSizeRequest hview+		let setS play spec = do+			widgetSetSizeRequest ascroll (-1) play+			widgetSetSizeRequest hscroll (-1) play+			widgetSetSizeRequest sscroll (-1) spec+		let pReq = max hReq aReq++		if natural * 2 > h then+			let half = max 0 (h`quot`2) in setS half half+		else if (max sReq natural) + pReq + spacing <= h then+			setS (-1) (max sReq natural)+		else do+			let ratio	= fromIntegral pReq / (fromIntegral sReq + fromIntegral pReq) :: Double+			    pNew	= max natural (round (ratio * fromIntegral h))+			    sNew	= max natural (h - pNew)+			setS pNew sNew+ 	-- Action buttons-	join	<- buttonNewWithMnemonic "_Join Server"-	refresh	<- buttonNewWithMnemonic "Refresh _current"-	set join 	[ buttonImage :=> imageNewFromStock stockConnect IconSizeButton-			, widgetSensitive := False ]-	set refresh	[ buttonImage :=> imageNewFromStock stockRefresh IconSizeButton+	serverbuttons <- hButtonBoxNew+	buttonBoxSetLayout serverbuttons ButtonboxSpread+	let action lbl icon = do+		b <- buttonNewWithMnemonic lbl+		set b	[ buttonImage :=> imageNewFromStock icon IconSizeButton 			, widgetSensitive := False ]-	-	serverbuttons <- hBoxNew False 0-	boxPackStart serverbuttons join PackRepel 0-	boxPackStart serverbuttons refresh PackRepel 0-	+		boxPackStartDefaults serverbuttons b+		return b++	st 	<- action "_Settings" stockProperties+	refresh	<- action "_Refresh" stockRefresh+	join	<- action "_Join" stockConnect+ 	-- Packing 	rightpane <- vBoxNew False spacing 	set rightpane  [ containerBorderWidth := spacing ] 	boxPackStart rightpane hostnamex PackNatural 1 	boxPackStart rightpane tbl PackNatural 0+	boxPackStart rightpane versionLabel PackNatural 0+	boxPackStart rightpane bools PackNatural 0 	boxPackStart rightpane allplayers PackGrow 0 	boxPackStart rightpane uscroll PackGrow 0-	boxPackStart rightpane serverbuttons PackNatural 2+	boxPackStart rightpane serverbuttons PackNatural spacingHalf  -	let launchTremulous = withTMVar current $ \gs -> do-		tst <- atomically $ tryTakeTMVar running-		whenJust tst (ignoreIOException . terminateProcess)-		config <- atomically $ readTMVar mconfig+	let launchTremulous gs = whenM (isEmptyMVar running) $ do+		putMVar running ()+		config	<- readMVar mconfig+		ss	<- readMVar msettings  		set join [ widgetSensitive := False ] -		pid <- maybeIO (runTremulous config gs)+		pid <- maybeIO $ runTremulous config gs (getSettings (address gs) ss) 		case pid of-			Nothing -> gtkError $ "Unable to run \"" ++ path ++ "\".\nHave you set your path correctly in Preferences?"+			Nothing -> do+				gtkError parent $ "Unable to run \"" ++ path ++ "\".\nHave you set your path correctly in Preferences?"+				set join [ widgetSensitive := True ]+				takeMVar running 				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 ]-			return ()-		return ()+			Just a -> do+				autoSignal mauto AutoPause+				forkIO $ do+					waitForProcess a+					postGUISync $ set join [ widgetSensitive := True ]+					takeMVar running+					autoSignal mauto AutoResume+				return () -	on join buttonActivated launchTremulous -	++	let updateSettings joining = do+		gs@GameServer{..}	<- readMVar current+		ss			<- readMVar msettings+		let cur = getSettings address ss+		if not joining || null (serverPass cur) then do+			new <- newSettingsDialog parent colors protected gs cur+			case new of+				Nothing -> return False+				Just n -> do+					let ss' = putSettings address n ss+					swapMVar msettings ss'+					unlessM (toFile ss') $+						gtkWarn parent "Unable to save server specific settings"+					return True+		else return False++	let launchWithSettings gs+		| protected gs	= whenM (updateSettings True) (launchTremulous gs)+		| otherwise	= launchTremulous gs+++	on join buttonActivated $ readWithMVar current launchWithSettings+	on st buttonActivated (updateSettings False >> return ())++ 	let setF boolJoin gs@GameServer{..} = do+		labelSetMarkup hostnamex $ showHostname colors hostname 		zipWithM_ labelSetMarkup info 			[ show address 			, (proto2string protocol ++ (case gamemod of-					Nothing	-> ""-					Just z	-> " (" ++ unpackorig z ++ ")"))-			, unpackorig mapname-			, maybeQ timelimit ++ " (" ++ maybeQ suddendeath ++ ")"-			, show slots ++ " (+" ++ show privslots ++ ")"-			, show gameping ++-				" (" ++ (show . intmean . filter validping . map ping) players ++ ")"+					SM.Nothing	-> ""+					SM.Just z	-> " (" ++ (unpack . original) z ++ ")"))+			, maybeS mapname+			, maybeQ timelimit ++ " / " ++ maybeQ suddendeath+			, show slots ++ " (+" ++ maybeQ privslots ++ ")"+			, show gameping ++ " / " ++ meanPing players+			, maybeS version 			]-		hostnamex `labelSetMarkup` showHostname colors hostname-		+		labelSetText versionLabel (maybeS version)+		labelSetText bools $	unwords	[ if unlagged then "unlagged" else ""+						, if protected then "password" else "" ]+ 		listStoreClear amodel 		listStoreClear hmodel 		listStoreClear smodel 		listStoreClear umodel-		+ 		let	sortedPlayers		= scoreSort players 			(s', a', h', u')	= partitionTeams sortedPlayers-		if null u' then do		+		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	+			widgetShow allplayers+			widgetHide uscroll 		else do 			mapM_ (listStoreAppend umodel) sortedPlayers 			treeViewColumnsAutosize uview 			widgetShow uscroll 			widgetShow uview 			widgetHide allplayers-		-		atomically $ replaceTMVar current gs-		-		set join [ widgetSensitive := True ]++		mask_ $ do+			tryTakeMVar current+			putMVar current gs++		whenM (isEmptyMVar running) $+			set join [ widgetSensitive := True ] 		set refresh [ widgetSensitive := True ]+		set st [ widgetSensitive := True ] -		when boolJoin launchTremulous-		return ()+		when boolJoin (launchWithSettings gs) -	let updateF PollResult{..} = withTMVar current $ \GameServer{address} ->+	let updateF PollResult{..} = readWithMVar current $ \GameServer{address} -> 			whenJust (serverByAddress address polled) (setF False)-			-	-	on refresh buttonActivated $ withTMVar current $ \x -> do+++	on refresh buttonActivated $ readWithMVar current $ \x -> do 		set refresh [ widgetSensitive := False ]-		Config {delays} <- atomically $ readTMVar mconfig+		Config {delays} <- readMVar mconfig 		forkIO $ do 			result <- pollOne delays (address x)-			-			whenJust result $ \new -> do-				pr <- atomically $ do-					pr@PollResult{polled} <- takeTMVar mpolled-					let pr' = pr ++			SM.whenJust result $ \new -> do+				pr <- do+					pr@PollResult{polled} <- takeMVar mpolled+					let pr' = pr 						{ polled = replace 							(\old -> address old == address new) 							new polled 						}-					putTMVar mpolled pr'+					putMVar mpolled pr' 					return pr'-						-				mm <- findIndex (\old -> address old == address new) <$>-					listStoreToList browserStore-				(fa, fb)	<- atomically (readTMVar mupdate)-				clans		<- atomically (readTMVar mclans)+				(_, fb)	<- readMVar mupdate+				clans	<- readMVar 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	+					browserUpdateOne browserStore new+					playerUpdateOne playerStore new+ 			postGUISync $ 				set refresh [ widgetSensitive := True ]-				+ 		return ()-		+ 	return (rightpane, updateF, setF) 	where 	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+	showHostname _ (TI _ "")	= "<i>Invalid name</i>"+	showHostname colors x		= pangoPretty colors x+	maybeQ			= SM.maybe "?" show+	maybeS			= SM.maybe "" (unpack . original)+	meanPing		= show . intmean . filter validping . map ping -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}+runTremulous :: Config -> GameServer -> ServerArg-> IO (Maybe ProcessHandle)+runTremulous Config{..} GameServer{..} ServerArg{..} = do+	(_,_,_,p) <- createProcess (proc com args) {cwd = ldir, close_fds = True} 	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])-		+	com = case protocol of+		70 -> tremGppPath+		_  -> tremPath++	args = concatMap (uncurry arg)+			[ ("connect", show address)+			, ("password", serverPass)+			, ("rconPassword", serverRcon)+			, ("name", serverName)+			]+ 	ldir = case takeDirectory com of 		"" -> Nothing 		x  -> Just x --ignoreIOException :: IO () -> IO ()-ignoreIOException = handle (\(_ :: IOError) -> return ())+arg :: String -> String -> [String]+arg _ "" = []+arg a s  = ['+':a, s] -maybeIO :: IO (Maybe a) -> IO (Maybe a)-maybeIO = handle (\(_ :: IOError) -> return Nothing)+playerView :: ColorArray -> String -> Bool -> IO (GenSimple ListStore Player)+playerView colors teamName showScore = do+	gen@(GenSimple _ view) <- newGenSimple =<< listStoreNew []+	select <- treeViewGetSelection view+	treeSelectionSetMode select SelectionNone+	addColumn gen teamName True [cellTextEllipsize := EllipsizeEnd] $ \rend ->+		cellSetMarkup rend . pangoPrettyBS colors . name+	when showScore $ do+		addColumn gen "Score" False [cellXAlign := 1] $ \rend item -> do+			set rend  [cellText := show $ kills item]+		return ()+	addColumn gen "Ping" False [cellXAlign := 1] $ \rend item ->+			set rend [ cellText := show $ ping item]+	return gen

@@ -0,0 +1,89 @@+module SettingsDialog where+import Graphics.UI.Gtk+import Control.Applicative+import Network.Tremulous.Protocol+import Control.Monad++import IndividualServerSettings+import TremFormatting+import Constants++--Favorite server commented out. Perhaps in a later version++newSettingsDialog :: Window -> ColorArray -> Bool -> GameServer -> ServerArg -> IO (Maybe ServerArg)+newSettingsDialog win colors requirepw GameServer{..} ServerArg{..} = do+	dia <- dialogNew+	set dia	[ windowTitle			:= "Server settings"+		, windowWindowPosition		:= WinPosCenterOnParent+		, windowTransientFor		:= win+		]++	dialogAddButton dia stockCancel ResponseCancel+	dialogAddButton dia stockOk     ResponseOk+	dialogSetDefaultResponse dia ResponseOk++	srv <- labelNew $ Just $ pangoPretty colors hostname+	set srv [ labelWrap		:= True+		, labelJustify		:= JustifyCenter+		, labelUseMarkup	:= True+		, labelAttributes 	:= [AttrWeight 0 (-1) WeightBold, AttrScale 0 (-1) 1.2]+		]+	labelSetLineWrapMode srv WrapPartialWords++	ip <- labelNew $ Just $ show address++	tbl <- tableNew 0 0 False+	set tbl	[ tableRowSpacing	:= spacingHalf+		, tableColumnSpacing	:= spacing+		]++	let easyAttach pos lbl tip def = do+		a <- labelNewWithMnemonic lbl+		b <- entryNew+		set b	[ entryActivatesDefault := True+			, entryText		:= def+			, entryWidthChars	:= 30 ]+		when (pos == 1 && requirepw) $ do+			labelSetAttributes a [AttrWeight 0 (-1) WeightBold]++		set a	[ labelMnemonicWidget	:= b+			, widgetTooltipText	:= Just tip ]+		miscSetAlignment a 0 0.5+		tableAttach tbl a 0 1 pos (pos+1) [Fill] [] 0 0+		tableAttach tbl b 1 2 pos (pos+1) [Expand, Fill] [] 0 0+		return b++	name	<- easyAttach 0 "Override _name:"+		"Set a custom name that will only be used on this server" serverName+	pass	<- easyAttach 1 "_Password:" "Server password" serverPass+	rcon	<- easyAttach 2 "_Rcon:" "Rcon password" serverRcon++	-- fav	<- checkButtonNewWithMnemonic "_Favorite server"+	-- toggleButtonSetActive fav serverFavorite++	box <- vBoxNew False spacing+	set box [ containerBorderWidth := spacing ]+	boxPackStart box srv PackNatural 0+	boxPackStart box ip PackNatural 0++	when requirepw $ do+		l <- labelNew (Just "This server requires a password!")+		labelSetAttributes l [AttrWeight 0 (-1) WeightBold]+		boxPackStart box l PackNatural 0+	boxPackStart box tbl PackNatural 0+	-- boxPackStart box fav PackNatural 0+	dbox <- dialogGetUpper dia+	boxPackStart dbox box PackNatural 0+	widgetShowAll dbox+	when requirepw (widgetGrabFocus pass)++	answer <- dialogRun dia+	case answer of+		ResponseOk 	-> Just <$> (ServerArg+						<$> get pass entryText+						<*> get rcon entryText+						<*> get name entryText+						<*> pure False) -- (toggleButtonGetActive fav)+					<* widgetDestroy dia+		_		-> widgetDestroy dia >> return Nothing+

@@ -1,84 +1,157 @@-module Toolbar where-+module Toolbar(newToolbar, getDNS) where import Graphics.UI.Gtk  import Control.Applicative-import Control.Exception+import Control.Concurrent 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.MicroTime +import GtkUtils import Types import Constants-import STM2-+import Monad2 import Config import About-import Clanlist--getDNS :: String -> String -> IO (Maybe SockAddr)-getDNS host port = handle (\(_ :: IOException) -> return Nothing) $ do-	AddrInfo _ _ _ _ addr _ <- Prelude.head `liftM` getAddrInfo Nothing (Just host) (Just port)-	return $ Just addr--	-whileTrue :: Monad m => m Bool -> m ()-whileTrue f = f >>= \t -> when t (whileTrue f)+import ClanFetcher+import AutoRefresh  newToolbar :: Bundle -> [ClanHook] -> [PolledHook] -> [ClanPolledHook] -> IO HBox-newToolbar bundle@Bundle{..} clanHook polledHook bothHook = do		+newToolbar bundle@Bundle{..} clanHook polledHook bothHook = do+	c		<- readMVar mconfig 	pb		<- progressBarNew 	set pb		[ widgetNoShowAll := True ]-	-	refresh		<- mkToolButton "Refresh all servers" stockRefresh "Ctrl+R or F5"-	clansync	<- mkToolButton "Sync clan list" stockSave "Ctrl+S or F6"		++	refresh		<- mkToolButton "Refresh all" stockRefresh "Ctrl+R or F5"+	clansync	<- mkToolButton "Sync clans" 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-			-	align		<- alignmentNew 0 0 0 0-	alignbox	<- hBoxNew False spacing-	set align [ containerChild := alignbox ]-	-	boxPackStartDefaults alignbox refresh-	boxPackStartDefaults alignbox clansync-	boxPackStartDefaults alignbox about-			-	pbrbox		<- hBoxNew False spacing+	auto		<- mkAuto (refreshMode c)++	doSync		<- mLock clansync (newClanSync bundle clanHook bothHook)+	doRefresh	<- mLock refresh (newRefresh bundle polledHook bothHook pb)+	autoRunner mauto mconfig doRefresh++	on about buttonActivated (newAbout parent)+	on clansync buttonActivated doSync+	on refresh buttonActivated doRefresh++	on auto toggled $ do+		act <- toggleButtonGetActive auto+		autoSignal mauto (if act then AutoStart else AutoStop)++	toolbar	<- hBoxNew False 0 -- should be spacing?+	boxPackStartDefaults toolbar refresh+	boxPackStartDefaults toolbar auto+	boxPackStartDefaults toolbar clansync+	boxPackStartDefaults toolbar about++	align <- alignmentNew 0 0 0 0+	set align [ containerChild := toolbar ]++	pbrbox <- hBoxNew False spacing 	set pbrbox [ containerBorderWidth := spacing ] 	boxPackStart pbrbox align PackNatural 0 	boxPackStart pbrbox pb PackGrow 0-	-	-	let serverRefresh = do-		progressBarSetFraction pb 0-		widgetShow pb-		refresh `set` [ widgetSensitive := False ]-		Config {masterServers, delays=delays@Delay{..}} <- atomically $ readTMVar mconfig-		-		start <- getMicroTime -		-- This is a stupid guess based on that about 110 servers will respond and the master-		-- will take about 200ms to respond-		PollResult { serversResponded } <- atomically $ readTMVar mpolled-		let serversGuess = if serversResponded == 0 then 110 else serversResponded-		let tremTime = (packetDuplication + 1) * packetTimeout-			+ serversGuess * throughputDelay + 200 * 1000-		-		forkIO $ do-			hosts <- catMaybes <$> mapM-				(\(host, port, proto) -> fmap (`MasterServer` proto) <$> getDNS host (show port))-				masterServers-			pbth <- forkIO $ whileTrue $ do+	on parent keyPressEvent $  do+		kmod <- eventModifier+		k <- map toLower <$> eventKeyName+		case kmod of+			[Control]+				| k == "r" -> liftIO doRefresh		>> return True+				| k == "s" -> liftIO doSync		>> return True+			[]	| k == "f5" -> liftIO doRefresh		>> return True+			[]	| k == "f6" -> liftIO doSync		>> return True+			[]	| k == "f7" -> liftIO (newAbout parent)	>> return True+			_ -> return False++	case (refreshMode c) of+		Startup	-> doRefresh+		Auto	-> autoSignal mauto AutoStart+		Manual	-> return ()+	when (autoClan c) doSync++	return pbrbox++-- The reason a hbox is used is so the icons always gets displayed regardless of the gtk setting+mkToolButton :: String -> StockId -> String -> IO Button+mkToolButton text icon tip = do+	button <- buttonNew+	img <- imageNewFromStock icon IconSizeButton+	lbl <- labelNew (Just text)+	box <- hBoxNew False 2+	boxPackStart box img PackNatural 0+	boxPackStart box lbl PackNatural 0+	containerAdd button box+	set button	[ buttonRelief		:= ReliefNone+			, buttonFocusOnClick	:= False+			, widgetTooltipText	:= Just tip ]+	return button++mkAuto :: RefreshMode -> IO ToggleButton+mkAuto refreshMode = do+	button <- toggleButtonNew+	set button [ toggleButtonActive := refreshMode == Auto ]+	img <- imageNewFromStock stockMediaPlay IconSizeButton+	containerAdd button img+	set button	[ buttonRelief		:= ReliefNone+			, buttonFocusOnClick	:= False+			, widgetTooltipText	:= Just "Refresh all servers periodically" ]+	return button++mLock :: WidgetClass w => w -> (IO () -> IO ()) -> IO (IO ())+mLock widget f = do+	m <- newEmptyMVar+	let lock = do+		putMVar m ()+		set widget [ widgetSensitive := False ]+	let unlock = do+		takeMVar m+		postGUISync (set widget [ widgetSensitive := True ])++	return $ whenM (isEmptyMVar m) (lock >> f unlock)+++newClanSync :: Bundle -> [ClanHook] -> [ClanPolledHook] -> IO () -> IO ()+newClanSync Bundle{..} clanHook bothHook unlock = do+	Config {clanSyncURL} <- readMVar mconfig+	forkIO $ do+		new <- getClanList clanSyncURL+		case new of+			Nothing	-> postGUISync $ gtkError parent "Unable to download clanlist"+			Just a	-> do+				swapMVar mclans a+				result <- readMVar mpolled+				postGUISync $ do+					mapM_ ($ a) clanHook+					mapM_ (\f -> f a result) bothHook+		unlock+	return ()++newRefresh :: Bundle -> [PolledHook] -> [ClanPolledHook] -> ProgressBar -> IO () -> IO ()+newRefresh Bundle{..} polledHook bothHook pb unlock = do+	progressBarSetFraction pb 0+	widgetShow pb+	Config {masterServers, delays=delays@Delay{..}} <- readMVar mconfig++	-- This is a stupid guess based on that about 110 servers will respond and the master+	-- will take about 200ms to respond+	PollResult { serversResponded } <- readMVar mpolled+	let serversGuess = if serversResponded == 0 then 110 else serversResponded+	let tremTime = (packetDuplication + 1) * packetTimeout+		+ serversGuess * throughputDelay + 200 * 1000++	forkIO $ do+		hosts <- catMaybes <$> mapM+			(\(host, port, proto) -> fmap (`MasterServer` proto) <$> getDNS host (show port))+			masterServers+		start <- getMicroTime+		pbth <- forkIO $ whileTrue $ do 				threadDelay 10000 --10 ms, 100 fps 				now <- getMicroTime 				let diff = now - start@@ -89,42 +162,15 @@ 					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-				mapM_ ($ result) polledHook-				mapM_ (\f -> f clans result) bothHook-				refresh `set` [ widgetSensitive := True ]-				widgetHide pb-		return ()-	on refresh buttonActivated serverRefresh--	Config {..} <- atomically $ readTMVar mconfig-	when autoMaster serverRefresh-	when autoClan doSync--	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-		+		result <- pollMasters delays hosts+		swapMVar mpolled result+		killThread pbth+		clans <- readMVar mclans+		autoSignal mauto AutoUpdate+		postGUISync $ do+			mapM_ ($ result) polledHook+			mapM_ (\f -> f clans result) bothHook+			widgetHide pb+		unlock+	return ()

@@ -2,32 +2,44 @@ import Data.Array import Data.Char import Network.Tremulous.NameInsensitive+import qualified Data.ByteString.Char8 as B+import Data.ByteString.Char8 (ByteString)  data TremFmt = TFColor !String | TFNone !String 	deriving (Show, Read)  type ColorArray = Array Int TremFmt -htmlEscape :: String -> String-htmlEscape = foldr f [] where-	f x xs = case x of -		'<' -> "&lt;" ++ xs-		'>' -> "&gt;" ++ xs-		'&' -> "&amp;" ++ xs-		_   -> x : xs -	+htmlEscapeBS :: ByteString -> ByteString+htmlEscapeBS = B.concat . B.foldr f [] where+	f x xs = case x of+		'<' -> "&lt;" : xs+		'>' -> "&gt;" : xs+		'&' -> "&amp;" : xs+		_   -> B.singleton x : xs++pangoPrettyBS :: ColorArray -> TI -> ByteString+pangoPrettyBS arr = B.pack . pangoColors arr . B.unpack . original++pangoPretty :: ColorArray-> TI -> String+pangoPretty arr = pangoColors arr . B.unpack . original+ pangoColors :: ColorArray -> String -> String pangoColors arr = f False where-	f n ('^':x:xs) | isAlphaNum x = case arr ! (a `mod` 8) of+	--Replace with colors+	f n ('^':x:xs) | isAlphaNum x = case arr ! (a `rem` 8) of 		TFColor color	-> close n ++ "<span color=\"" ++ color ++ "\">" ++ f True xs 		TFNone	_	-> close n ++ f False xs 		where a = ord x - ord '0'-			  -			-	f n (x:xs)	= x:f n xs+	--Escape pango+	f n (x:xs) = case x of+		'<' -> "&lt;" ++ f n xs+		'>' -> "&gt;" ++ f n xs+		'&' -> "&amp;" ++ f n xs+		_   -> x : f n xs+ 	f n []		= close n-	+ 	close n = if n then "</span>" else "" -pangoPretty :: ColorArray-> TI -> String-pangoPretty arr = pangoColors arr . htmlEscape . unpackorig+

@@ -1,22 +1,32 @@ module Types (-	module Control.Concurrent.STM-	, Bundle(..), ClanHook, PolledHook, ClanPolledHook, SetCurrent+	module Control.Concurrent, module ConcurrentUtil+	, Bundle(..), ClanHook, PolledHook, ClanPolledHook, SetCurrent, BrowserStore, PlayerStore ) where import Graphics.UI.Gtk++import Control.Concurrent+import ConcurrentUtil+import Network.Tremulous.Protocol import Config import ClanFetcher-import Control.Concurrent.STM-import Network.Tremulous.Protocol+import IndividualServerSettings+import AutoRefresh  data Bundle = Bundle {-	  mpolled	:: !(TMVar PollResult)-	, mconfig	:: !(TMVar Config)-	, mclans	:: !(TMVar [Clan])+	  mpolled	:: !(MVar PollResult)+	, mconfig	:: !(MVar Config)+	, mclans	:: !(MVar [Clan])+	, mrefresh	:: !(MVar ()) 	, parent	:: !Window-	, browserStore	:: !(ListStore GameServer)+	, browserStore	:: !BrowserStore+	, playerStore	:: !PlayerStore+	, msettings	:: !(MVar ServerSettings)+	, mauto		:: !(MVar AutoSignal) 	}  type ClanHook		= [Clan] -> IO () type PolledHook		= PollResult -> IO () type ClanPolledHook	= [Clan] -> PollResult -> IO () type SetCurrent		= Bool -> GameServer -> IO ()+type PlayerStore	= ListStore (TI, GameServer)+type BrowserStore	= ListStore GameServer