packages feed

apelsin 1.2 → 1.2.1

raw patch · 21 files changed

+365/−394 lines, 21 filesdep +cpphsdep +xdg-basedirdep ~tremulous-query

Dependencies added: cpphs, xdg-basedir

Dependency ranges changed: tremulous-query

Files

apelsin.cabal view
@@ -1,16 +1,18 @@ Name:                   apelsin-Version:                1.2+Version:                1.2.1 Author:                 Christoffer Öjeling Maintainer:             christoffer@ojeling.net License:                GPL-3 License-File:           LICENSE Category:               Network Synopsis:               Server and community browser for the game Tremulous-Description:            A gtk2hs server and clan browser for the open source game Tremulous <http://tremulous.net>.-                        Both Tremulous 1.1 and GPP are supported.-			.-                        Features filtering, player search, a list of online clan members, a clan list and basic perferences.+Description:+  A gtk2hs server and clan browser for the open source game Tremulous+  <http://tremulous.net>. Both Tremulous 1.1 and GPP are supported. +  Features filtering, player search, a list of online clan members,+  a clan list and basic perferences.+ Cabal-Version:          >= 1.10 Build-Type:             Simple Data-Dir:               share@@ -23,7 +25,7 @@                         icons/hicolor/24x24/apps/apelsin.png                         icons/hicolor/64x64/apps/apelsin.png -Tested-With:            GHC==7.0.3+Tested-With:            GHC==7.6.1   Flag relativePath@@ -32,16 +34,19 @@  Executable apelsin   Default-Language:     Haskell2010-  Default-Extensions:   BangPatterns NamedFieldPuns RecordWildCards-                        ScopedTypeVariables OverloadedStrings TupleSections GADTs+  Default-Extensions:   BangPatterns NamedFieldPuns RecordWildCards GADTs+                        ScopedTypeVariables OverloadedStrings TupleSections+   Other-Extensions:     CPP StandaloneDeriving+   Build-Depends:        base>=4.3&&<5, array, mtl, containers, transformers,                         bytestring, directory, filepath, HTTP, network,-                        tremulous-query>=1.0.5, gtk, glib, process, deepseq+                        tremulous-query>=1.0.6, gtk, glib, process, deepseq,+                        cpphs, xdg-basedir+   Hs-Source-Dirs:       src   Main-is:              Apelsin.hs-  Other-Modules:        System.Environment.XDG.BaseDir-                        GtkExts+  Other-Modules:        GtkExts                         About                         AutoRefresh                         ClanFetcher@@ -68,7 +73,8 @@                         OnlineClans                         Paths_apelsin -  Ghc-Options:          -Wall -threaded -fno-warn-unused-do-bind -funbox-strict-fields+  Ghc-Options:          -Wall -threaded -fno-warn-unused-do-bind+                        -funbox-strict-fields -optP --cpp -pgmP cpphs    if !flag(relativePath)     cpp-options:        -DCABAL_PATH
src/About.hs view
@@ -14,7 +14,7 @@ 		, windowTransientFor	:= win 		, aboutDialogProgramName:= programName 		, aboutDialogVersion	:= showVersion version-		, aboutDialogCopyright	:= "Copyright © 2011\nChristoffer Öjeling <christoffer@ojeling.net>"+		, aboutDialogCopyright	:= "Copyright © 2011-2012\nChristoffer Öjeling <christoffer@ojeling.net>" 		, aboutDialogComments	:= "A tremulous server and community browser\nLicense: GPLv3" 		, aboutDialogWebsite	:= "http://ojeling.net" 		]
src/Apelsin.hs view
@@ -86,8 +86,8 @@  	-- save the current window size and pane positon on exit 	on win deleteEvent $ tryEvent $ liftIO $ do-		Config {autoGeometry} <- readMVar (mconfig bundle)-		when autoGeometry $ do+		Config {restoreGeometry} <- readMVar (mconfig bundle)+		when restoreGeometry $ do 			file		<- inCacheDir "windowsize" 			(winw, winh)	<- windowGetSize win 			ppos		<- panedGetPosition pane@@ -108,7 +108,7 @@ 	widgetShowAll leftView  	-- Restore the window size and pane position-	when (autoGeometry config) $ ignoreIOException $ do+	when (restoreGeometry config) $ ignoreIOException $ do 		file	<- inCacheDir "windowsize" 		fx	<- readFile file 		whenJust (mread fx) $ \(winw::Int, winh, ppos::Int) -> do
src/AutoRefresh.hs view
@@ -14,7 +14,7 @@ data State = Running !ThreadId | Paused | Stopped  autoSignal :: MVar AutoSignal -> AutoSignal -> IO ()-autoSignal m = putMVar m+autoSignal = putMVar  autoRunner :: MVar AutoSignal -> MVar Config -> IO a -> IO ThreadId autoRunner m mconfig refreshAction = forkIO $ go Stopped Nothing@@ -54,7 +54,7 @@  startAuto :: MVar Config -> Maybe MicroTime -> IO a -> IO ThreadId startAuto mconfig lastRefresh refreshAction = uninterruptibleMask $ \restore -> forkIO $ do-		delay <- autoDelay <$> readMVar mconfig+		delay <- autoRefreshDelay <$> readMVar mconfig 		whenJust lastRefresh $ \past -> do 			now <- getMicroTime 			when (past+delay > now) $
src/Clanlist.hs view
@@ -50,15 +50,15 @@  	addColumnFS gen "_Name" False (Just $ comparing $ name . fst) 		(rememberColumn bundle 1)-		cellRendererTextNew [] (simpleColumn (original . name))+		fastCellTextRenderer [] (simpleColumn (original . name))  	addColumnFS gen "_Tag" False (Just $ comparing $ tagexpr . fst) 		(rememberColumn bundle 2)-		cellRendererTextNew [] (markupColumn (prettyTagExpr . tagexpr))+		fastCellTextRenderer [] (markupColumn (prettyTagExpr . tagexpr))  	addColumnFS gen "Website" False Nothing 		(const (return ()))-		cellRendererTextNew [] $ \rend (Clan{..},_) -> do+		fastCellTextRenderer [] $ \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 ]@@ -66,10 +66,10 @@  	addColumnFS gen "IRC" False Nothing 		(const (return ()))-		cellRendererTextNew [] (simpleColumn irc)+		fastCellTextRenderer [] (simpleColumn irc)  	Config{..} <- readMVar mconfig-	treeSortableSetSortColumnId sorted clanlistSort clanlistOrder+	treeSortableSetSortColumnId sorted clanlistSortColumn clanlistOrder   	treeModelFilterSetVisibleFunc filtered $ \iter -> do@@ -85,7 +85,7 @@  		when (title == Just "Website" && (not . B.null) website) $ openInBrowser $ 			if websitealive then B.unpack website-					else "http://wayback.archive.org/web/*/" ++ (B.unpack website)+					else "http://wayback.archive.org/web/*/" ++ B.unpack website  		when active $ whenJust clanserver $ \server -> do 			P.PollResult{..} <- readMVar mpolled@@ -119,6 +119,6 @@ rememberColumn Bundle{..} n col = do 	order <- treeViewColumnGetSortOrder col 	current <- takeMVar mconfig-	let new = current {clanlistSort = n, clanlistOrder = order}+	let new = current {clanlistSortColumn = n, clanlistOrder = order} 	putMVar mconfig new 	configToFile parent new
src/Config.hs view
@@ -1,6 +1,14 @@-module Config (Config(..), ColorTheme, configFromFile, configToFile-	, makeColorsFromList, RefreshMode(..)+{-# LANGUAGE CPP #-}+module Config(+      Config(..)+    , ColorTheme+    , RefreshMode(..)+    , defaultConfig+    , configFromFile+    , configToFile+    , makeColorsFromList ) where+import Prelude hiding (catch) import Graphics.UI.Gtk (SortType(..), Window) import Data.Array import Data.Char@@ -20,147 +28,176 @@ type ColorTheme = Array Int TremFmt  data SortingOrderPretty = Ascending | Descending-	deriving (Show, Read, Enum)+    deriving (Show, Read, Enum)  data RefreshMode = Startup | Auto | Manual-	deriving (Show, Read, Eq)+    deriving (Show, Read, Eq)  data Config = Config-	{ masterServers :: ![(String, Int, Int)]-	, clanSyncURL	:: !String-	, tremPath-	, tremGppPath	:: !String-	, refreshMode	:: !RefreshMode-	, autoClan-	, autoGeometry	:: !Bool-	, autoDelay	:: !MicroTime-	, filterBrowser-	, filterPlayers	:: !String-	, filterEmpty	:: !Bool-	, browserSort-	, playersSort-	, clanlistSort	:: !Int-	, browserOrder-	, playersOrder-	, clanlistOrder	:: !SortType-	, delays	:: !Delay-	, colors	:: !ColorTheme-	}+    { masterServers         :: ![(String, Int, Int)]+    , clanlistURL           :: !String+    , tremulousPath+    , tremulousGppPath+    , unvanquishedPath      :: !String+    , refreshMode           :: !RefreshMode+    , autoClan+    , restoreGeometry       :: !Bool+    , autoRefreshDelay      :: !MicroTime+    , filterBrowser+    , filterPlayers         :: !String+    , showEmpty             :: !Bool+    , browserSortColumn+    , playersSortColumn+    , clanlistSortColumn    :: !Int+    , browserOrder+    , playersOrder+    , clanlistOrder         :: !SortType+    , delays                :: !Delay+    , colors                :: !ColorTheme+    } +defaultConfig :: Config+defaultConfig = Config+    { masterServers         = [ ("master.tremulous.net", 30710, 69)+                              , ("master.tremulous.net", 30700, 70)+                              , ("unvanquished.net", 27950, 86)+                              ]+    , clanlistURL           = "http://ddos-tremulous.eu/cw/api/2/clanlist" +#if defined(mingw32_HOST_OS) || defined(__MINGW32__)+    , tremulousPath         = "C:\\Program Files\\Tremulous\\tremulous.exe"+    , tremulousGppPath      = "C:\\Program Files\\Tremulous\\tremulous-gpp.exe"+    , unvanquishedPath      = "C:\\Program Files\\Unvanquished\\daemon.exe"+#else+    , tremulousPath         = "tremulous"+    , tremulousGppPath      = "tremulous-gpp"+    , unvanquishedPath      = "unvanquished"+#endif++    , refreshMode           = Startup+    , autoClan              = True+    , restoreGeometry       = True+    , autoRefreshDelay      = 120000000 -- 120 seconds+    , filterBrowser         = ""+    , filterPlayers         = ""+    , showEmpty             = True+    , browserSortColumn     = 3+    , playersSortColumn     = 0+    , clanlistSortColumn    = 1+    , browserOrder          = ascending+    , playersOrder          = ascending+    , clanlistOrder         = ascending+    , delays                = defaultDelay+    , colors                = makeColorsFromList+                                [ TremFmt False "#000000"+                                , TremFmt True  "#d60503"+                                , TremFmt True  "#25c200"+                                , TremFmt True  "#eab93d"+                                , TremFmt True  "#0021fe"+                                , TremFmt True  "#04c9c9"+                                , TremFmt True  "#e700d7"+                                , TremFmt False "#000000"+                                ]+    }+    where ascending = (toEnum . fromEnum) Ascending+++#define NS(x) (showKV x #x)+#define NSF(x, y) (showKV ((y) x) #x) 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+    [ NS(masterServers)+    , NS(clanlistURL)+    , NS(tremulousPath)+    , NS(tremulousGppPath)+    , NS(unvanquishedPath)+    , NS(refreshMode)+    , NS(autoClan)+    , NS(restoreGeometry)+    , NSF(autoRefreshDelay, (`quot`1000000))+    , NS(filterBrowser)+    , NS(filterPlayers)+    , NS(showEmpty)+    , NS(browserSortColumn)+    , NS(playersSortColumn)+    , NS(clanlistSortColumn)+    , NSF(browserOrder, conv)+    , NSF(playersOrder, conv)+    , NSF(clanlistOrder, conv)+    , NS(packetTimeout)+    , NS(packetDuplication)+    , NS(throughputDelay)+    ] ++ zipWith+        (\a b -> showKV b ("color" ++ [a])) ['0'..'7']+        (elems colors)+    where+    conv :: SortType -> SortingOrderPretty+    conv = toEnum . fromEnum+    showKV :: Show v => v -> String -> String+    showKV v k = k ++ " " ++ show v +#define NP(x) x <- getKV #x id (x defaultConfig)+#define NP_NODEF(x) x <- getKV #x id+#define NPF(x, f) x <- getKV #x (f) (x defaultConfig) 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"]+    NP(masterServers)+    NP(clanlistURL)+    NP(tremulousPath)+    NP(tremulousGppPath)+    NP(unvanquishedPath)+    NP(refreshMode)+    NP(autoClan)+    NP(restoreGeometry)+    NPF(autoRefreshDelay, (*1000000))+    NP(filterBrowser)+    NP(filterPlayers)+    NP(showEmpty)+    NP(browserSortColumn)+    NP(playersSortColumn)+    NP(clanlistSortColumn)+    NPF(browserOrder , conv)+    NPF(playersOrder , conv)+    NPF(clanlistOrder, conv)+    NP_NODEF(packetTimeout) (packetTimeout defaultDelay)+    NP_NODEF(packetDuplication) (packetDuplication defaultDelay)+    NP_NODEF(throughputDelay) (throughputDelay defaultDelay)+    colors <- makeColorsFromList <$> zipWithM+        (\a b -> getKV ("color" ++ [a]) id b)+        ['0'..'7']+        (elems (colors defaultConfig))+    return Config{delays = Delay{..}, ..}+    where+    conv :: SortingOrderPretty -> SortType+    conv = toEnum . fromEnum+    getKV :: Read b  => String -> (b -> c) -> c -> State [(String, String)] c+    getKV key f def = do+        s <- get+        let (e, s') = lookupDelete key s+        put s'+        return $ SM.maybe def f $ smread =<< e + smread :: (Read a) => String -> SM.Maybe a smread x = case reads x of-	[(a, _)]	-> SM.Just a-	_		-> SM.Nothing+    [(a, _)]    -> SM.Just a+    _       -> SM.Nothing +makeColorsFromList :: [e] -> Array Int e+makeColorsFromList = listArray (0,7)+ 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 :: Window -> Config -> IO () configToFile win config = do-	file <- inConfDir "config"-	handle err $ do-	writeFile file (newSave config)-	where-	err (e::IOError) = gtkWarn win $ "Unable to save settings:\n" ++ show e-+    file <- inConfDir "config"+    handle err $ writeFile file (newSave config)+    where+    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-	return $ parse cont-	where-	err (_::IOError) = return $ parse ""+configFromFile = catch+    (parse <$> (readFile =<< inConfDir "config"))+    (\(_::IOError) -> return defaultConfig)
src/Constants.hs view
@@ -8,6 +8,7 @@ import System.Process import Control.Concurrent import Control.Exception+import Control.Monad  #ifdef CABAL_PATH import Paths_apelsin hiding (getDataDir)@@ -39,19 +40,16 @@ #endif  -defaultTremulousPath, defaultTremulousGPPPath:: FilePath trace :: String -> IO () defaultBrowser :: String -> IO CreateProcess+ #if defined(mingw32_HOST_OS) || defined(__MINGW32__)-defaultTremulousPath	= "C:\\Program Files\\Tremulous\\tremulous.exe"-defaultTremulousGPPPath	= "C:\\Program Files\\Tremulous\\tremulous-gpp.exe" trace _			= return () defaultBrowser x	= do 	ddir <- getDataDir 	return (proc "wscript" [ddir </> "open.js", x])+ #else-defaultTremulousPath	= "tremulous"-defaultTremulousGPPPath	= "tremulous-gpp" trace x			= hPutStrLn stderr x >> hFlush stderr  #if defined(__APPLE__) || defined(__MACH__)@@ -68,7 +66,7 @@ 	(_,_,_,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 ()+	forkIO $ void $ waitForProcess hdl 	return ()  spacing, spacingHalf, spacingBig, spacingHuge :: Integral i => i
src/FindPlayers.hs view
@@ -31,7 +31,7 @@ 		s <- readIORef current 		return $ smartFilter s 				[ cleanedCase item-				, proto2string protocol+				, protoToAbbr protocol 				, SM.maybe "" cleanedCase gamemod 				] @@ -57,23 +57,23 @@  	addColumnFS gen "_Name" True (Just (comparing fst)) 		(rememberColumn bundle 0)-		cellRendererTextNew+		fastCellTextRenderer 		[cellTextEllipsize := EllipsizeEnd] 		(\rend -> cellSetMarkup rend . pangoPrettyBS colors . fst)  	addColumnFS gen "_Server" True (Just (comparing (hostname . snd))) 		(rememberColumn bundle 1)-		cellRendererTextNew+		fastCellTextRenderer 		[cellTextEllipsize := EllipsizeEnd] 		(\rend -> cellSetMarkup rend . pangoPrettyBS colors . hostname . snd) -	treeSortableSetSortColumnId sorted playersSort playersOrder+	treeSortableSetSortColumnId sorted playersSortColumn playersOrder  	on view cursorChanged $ do 		(path, _) <- treeViewGetCursor view 		setCurrent False . snd =<< getElementPath gen path -	on view rowActivated $ \path _ -> do+	on view rowActivated $ \path _ -> 		setCurrent True . snd =<< getElementPath gen path  	return gen@@ -96,6 +96,6 @@ rememberColumn Bundle{..} n col = do 	order <- treeViewColumnGetSortOrder col 	current <- takeMVar mconfig-	let new = current {playersSort = n, playersOrder = order}+	let new = current {playersSortColumn = n, playersOrder = order} 	putMVar mconfig new 	configToFile parent new
src/GtkUtils.hs view
@@ -55,6 +55,7 @@ 			=> !(store a) 			-> !TreeView 			-> GenSimple store a+ data GenFilterSort store a where 	GenFilterSort	:: ( TreeModelClass (store a), TypedTreeModelClass store 			   , TreeModelClass filter, TreeModelFilterClass filter@@ -82,14 +83,14 @@ 	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+	rend <- fastCellTextRenderer 	set rend rendOpts-	set rend [cellTextEllipsize := EllipsizeEnd] 	cellLayoutPackStart col rend True 	cellLayoutSetAttributeFunc col rend store $ \iter -> do 		item <- getElementIter gen iter@@ -127,6 +128,11 @@ 			g <$> treeModelGetRow store rit1 <*> treeModelGetRow store rit2  +fastCellTextRenderer :: IO CellRendererText+fastCellTextRenderer = do+	rend <- cellRendererTextNew+	cellRendererTextSetFixedHeightFromFont rend 1+	return rend  getIterUnsafe :: TreeModelClass self => self -> TreePath -> IO TreeIter getIterUnsafe model path =
src/IndividualServerSettings.hs view
@@ -48,7 +48,7 @@ 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"+	where f (SockAddrInet (PortNum port) ip, ServerArg a b c d) = intercalate "\t" 		[ intToHex 8 (ntohl ip) 		, intToHex 4 (ntohs port) 		, a, b, c
src/InfoBox.hs view
@@ -6,10 +6,10 @@ newInfobox what = do 	lst <- mapM (labelNew . Just) 		["Showing", "0", " out of", "0", ' ' : what]-		+ 	let (_:a:_:b:_) = lst 	mapM_ (\x -> set x [ labelWidthChars := 4 ] >> miscSetAlignment x 1 0) [a,b]-	+ 	bar <- mkStatusBar lst 	return (bar, a, b) @@ -21,7 +21,7 @@ 	let (_:a:_:b:_:c:_) = lst 	mapM_ (\x -> set x [ labelWidthChars := 4 ] >> miscSetAlignment x 1 0) [a,b,c] 	set c [ labelWidthChars := 3 ]-	+ 	bar <- mkStatusBar lst 	return (bar, a, b, c) @@ -34,5 +34,3 @@ 	boxPackStart vb sep PackNatural 0 	boxPackStart vb box PackNatural 0 	return vb-	-
src/Monad2.hs view
@@ -14,10 +14,10 @@ 	Just a	-> f a  whenM :: Monad m => m Bool -> m () -> m ()-whenM c m = c >>= \t -> if t then m else return ()+whenM c m = c >>= \t -> when t m  unlessM :: Monad m => m Bool -> m () -> m ()-unlessM c m = c >>= \t -> if not t then m else return ()+unlessM c m = c >>= \t -> when (not t) m  getDNS :: String -> String -> IO (Maybe SockAddr) getDNS host port = handle (\(_ :: IOException) -> return Nothing) $
src/NumberSerializer.hs view
@@ -2,6 +2,7 @@ import Data.Bits import Network.Tremulous.SocketExtensions import Network.Socket+import Data.Foldable  intToHex :: (Integral i, Bits i) => Int -> i -> String intToHex = go [] where@@ -12,9 +13,8 @@ 	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+hexToInt = foldl' (\acc x -> (acc `shiftL` 4) .|. toInt x) 0+	where 	toInt c | c' <= 0x39 = c' - 0x30 	        | otherwise  = c' - (0x61-0xa) 	        where c' = conv c@@ -22,4 +22,6 @@   stringToSockAddr :: String -> String -> SockAddr-stringToSockAddr ip port = SockAddrInet (PortNum (htons (hexToInt port))) (htonl (hexToInt ip))+stringToSockAddr ip port = SockAddrInet+	(PortNum (htons (hexToInt port)))+	(htonl (hexToInt ip))
src/OnlineClans.hs view
@@ -67,7 +67,7 @@ type OnlineView = Forest (Either Clan (TI, P.GameServer))  associatePlayerToClans :: PlayerList -> [Clan] -> [(Clan, PlayerList)]-associatePlayerToClans players clans = map f clans+associatePlayerToClans players = map f 	where 	f c@Clan{tagexpr} = (c, filter (cmp tagexpr) players) 	cmp e = matchTagExpr e . fst
src/Preferences.hs view
@@ -1,4 +1,5 @@ {-# LANGUAGE CPP #-}+-- This file is horribly coded :( A good example why the gtk code should be separate module Preferences (newPreferences) where import Graphics.UI.Gtk @@ -31,7 +32,7 @@ 	-- Default filters 	(  tbl 	 , [filterBrowser, filterPlayers]-	 , filterEmpty+	 , showEmpty 	 ) <- configTable 		[ "_Browser:" 		, "_Find players:"@@ -39,38 +40,42 @@ 	filters <- framed "Default filters" tbl  	-- Tremulous path-	(pathstbl, [tremPath, tremGppPath]) <- pathTable parent ["_Tremulous 1.1:", "Tremulous _GPP:"]-	paths <- framed "Tremulous path or command" pathstbl+	path_table       <- paddedTableNew+	tremulousPath    <- pathInsertTable parent path_table 0 "_Tremulous 1.1:"+	tremulousGppPath <- pathInsertTable parent path_table 1 "Tremulous _GPP:"+	unvanquishedPath <- pathInsertTable parent path_table 2 "_Unvanquished:"+	paths            <- framed "Path or command" path_table  	-- Startup 	autoClan	<- checkButtonNewWithMnemonic "_Sync clan list"-	autoGeometry	<- checkButtonNewWithMnemonic "Restore _window geometry from previous session"+	restoreGeometry	<- checkButtonNewWithMnemonic "Restore _window geometry from previous session" 	startupBox <- vBoxNew False 0 	boxPackStartDefaults startupBox autoClan-	boxPackStartDefaults startupBox autoGeometry+	boxPackStartDefaults startupBox restoreGeometry 	startup <- framed "On startup" startupBox  	--Refresh mode 	rb1 <- radioButtonNewWithMnemonic "_Once at startup"-	rb2 <- radioButtonNewWithMnemonicFromWidget rb1 "_Periodically each"+	rb2 <- radioButtonNewWithMnemonicFromWidget rb1 "_Periodically" 	rb3 <- radioButtonNewWithMnemonicFromWidget rb1 "_Manually"-	autoDelay <- spinButtonNewWithRange 0 3600 1-	seconds <- labelNew (Just "s") +	ar <- labelNewWithMnemonic "_Auto Refresh period:"+	autoRefreshDelay <- spinButtonNewWithRange 0 3600 1+	set ar [labelMnemonicWidget := autoRefreshDelay]+	seconds <- labelNew (Just "s") 	delaybox <- hBoxNew False spacing-	boxPackStart delaybox autoDelay PackNatural 0+	boxPackStart delaybox ar PackNatural 0+	boxPackStart delaybox autoRefreshDelay 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 rb2 	boxPackStartDefaults rbBox rb3+	boxPackStartDefaults rbBox delaybox 	refreshmode <- framed "Refresh all" rbBox + 	-- Colors 	(colorTbl, colorList) <- numberedColors 	colorWarning <- labelNew (Just "Note: Requires a restart to take effect")@@ -108,12 +113,13 @@ 		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 showEmpty		[ toggleButtonActive := C.showEmpty c]+		set tremulousPath	[ entryText := C.tremulousPath c ]+		set tremulousGppPath	[ entryText := C.tremulousGppPath c]+		set unvanquishedPath	[ entryText := C.unvanquishedPath c] 		set autoClan		[ toggleButtonActive := C.autoClan c]-		set autoGeometry	[ toggleButtonActive := C.autoGeometry c]-		set autoDelay		[ spinButtonValue := fromIntegral (C.autoDelay c `quot` 1000000) ]+		set restoreGeometry	[ toggleButtonActive := C.restoreGeometry c]+		set autoRefreshDelay	[ spinButtonValue := fromIntegral (C.autoRefreshDelay c `quot` 1000000) ] 		set packetTimeout'	[ spinButtonValue := fromIntegral (packetTimeout `quot` 1000) ] 		set packetDuplication'	[ spinButtonValue := fromIntegral packetDuplication ] 		set throughputDelay'	[ spinButtonValue := fromIntegral (throughputDelay `quot` 1000) ]@@ -122,27 +128,23 @@ 		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-			f (a ,b) (TFNone c) = do-				colorButtonSetColor a (hexToColor c)-				toggleButtonSetActive b False-				-- Apparently this is needed too+		where	f (a, b) (TremFmt active color) = do+				colorButtonSetColor a (hexToColor color)+				toggleButtonSetActive b active 				toggleButtonToggled b  	updateF  	_CONNECT(filterBrowser, editableChanged, entryText, C.filterBrowser)-	_CONNECT(filterEmpty, toggled, toggleButtonActive, C.filterEmpty)+	_CONNECT(showEmpty, toggled, toggleButtonActive, C.showEmpty) 	_CONNECT(filterPlayers, editableChanged, entryText, C.filterPlayers) -	_CONNECT(tremPath, editableChanged, entryText, C.tremPath)-	_CONNECT(tremGppPath, editableChanged, entryText, C.tremGppPath)+	_CONNECT(tremulousPath, editableChanged, entryText, C.tremulousPath)+	_CONNECT(tremulousGppPath, editableChanged, entryText, C.tremulousGppPath)+	_CONNECT(unvanquishedPath, editableChanged, entryText, C.unvanquishedPath) -	--_CONNECT(autoMaster, toggled, toggleButtonActive, C.autoMaster) 	_CONNECT(autoClan, toggled, toggleButtonActive, C.autoClan)-	_CONNECT(autoGeometry, toggled, toggleButtonActive, C.autoGeometry)+	_CONNECT(restoreGeometry, toggled, toggleButtonActive, C.restoreGeometry)   	let radiofunc value = update (\x -> x { C.refreshMode = value})@@ -154,9 +156,9 @@ 	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 autoRefreshDelay $ do+		value <- (*1000000) <$> spinButtonGetValueAsInt autoRefreshDelay+		update (\x -> x { C.autoRefreshDelay = fromIntegral value})  	onValueSpinned packetTimeout' $ do 		packetTimeout <- (*1000) <$> spinButtonGetValueAsInt packetTimeout'@@ -171,13 +173,12 @@ 		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+		rawcolors <- forM colorList $ \(colb, cb) ->+			TremFmt <$> get cb toggleButtonActive+				<*> (colorToHex <$> colorButtonGetColor colb) 		update $ \x -> x {C.colors = C.makeColorsFromList rawcolors} -	forM colorList $ \(colb, cb) -> do+	forM_ colorList $ \(colb, cb) -> do 		on cb toggled updateColors 		afterColorSet colb updateColors @@ -206,20 +207,15 @@ 	rt <- zipWithM easyAttach [0..] ys 	return (tbl, rt, empty) -pathTable :: Window -> [String] -> IO (Table, [Entry])-pathTable parent ys = do-	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] [] 0 0-		tableAttach tbl box 1 2 pos (pos+1) [Expand, Fill] [] 0 0-		return ent--	rt	<- zipWithM easyAttach [0..] ys-	return (tbl, rt)+pathInsertTable :: Window -> Table -> Int -> String -> IO Entry+pathInsertTable parent tbl 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] [] 0 0+	tableAttach tbl box 1 2 pos (pos+1) [Expand, Fill] [] 0 0+	return ent  mkInternals :: IO (Table, [SpinButton]) mkInternals = do@@ -239,7 +235,7 @@  	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" )+			, ("Maximum extra _requests:", "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)
src/ServerBrowser.hs view
@@ -25,45 +25,46 @@ 	addColumnFS gen "_Game" False 		(Just (comparing protocol `mappend` comparing gamemod `mappend` comparing gameping)) 		(rememberColumn bundle 0)-		cellRendererTextNew+		fastCellTextRenderer 		[] 		(\rend -> cellSetText rend . showGame)  	addColumnFS gen "_Name" True 		(Just (comparing hostname `mappend` comparing gameping)) 		(rememberColumn bundle 1)-		cellRendererTextNew+		fastCellTextRenderer 		[cellTextEllipsize := EllipsizeEnd] 		(\rend -> cellSetMarkup rend . pangoPrettyBS colors . hostname)  	addColumnFS gen "_Map" False 		(Just (comparing mapname `mappend` comparing gameping)) 		(rememberColumn bundle 2)-		cellRendererTextNew []+		fastCellTextRenderer+		[] 		(\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+		fastCellTextRenderer 		[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+		fastCellTextRenderer 		[cellXAlign := 1] 		(\rend x -> set rend [cellText := showPlayers x])  -	treeSortableSetSortColumnId sorted browserSort browserOrder+	treeSortableSetSortColumnId sorted browserSortColumn browserOrder  	(infobox, statNow, statTot, statRequested) <- newInfoboxBrowser  	(filterbar, current) <- newFilterBar parent filtered statNow filterBrowser 	empty <- checkButtonNewWithMnemonic "_empty"-	set empty [ toggleButtonActive := filterEmpty ]+	set empty [ toggleButtonActive := showEmpty ] 	boxPackStart filterbar empty PackNatural spacingHalf 	on empty toggled $ do 		treeModelFilterRefilter filtered@@ -73,15 +74,14 @@ 	treeModelFilterSetVisibleFunc filtered $ \iter -> do 		GameServer{..}	<- treeModelGetRow raw iter 		s		<- readIORef current-		showEmpty	<- toggleButtonGetActive empty-		return $ (showEmpty || not (null players)) &&-			(smartFilter s-				[ cleanedCase hostname-				, SM.maybe "" cleanedCase mapname-				, SM.maybe "" cleanedCase version-				, proto2string protocol-				, SM.maybe "" cleanedCase gamemod-				])+		showEmpty_	<- toggleButtonGetActive empty+		return $ (showEmpty_ || nplayers > 0) &&+			smartFilter s	[ cleanedCase hostname+							, SM.maybe "" cleanedCase mapname+							, SM.maybe "" cleanedCase version+							, protoToAbbr protocol+							, SM.maybe "" cleanedCase gamemod+							]  	on view cursorChanged $ do 		(path, _) <- treeViewGetCursor view@@ -109,7 +109,7 @@  	return (box, updateF) 	where-	showGame GameServer{..} = B.concat (proto2string protocol : SM.maybe [] ((\x -> ["-",x]) . original) gamemod)+	showGame GameServer{..} = B.concat (protoToAbbr protocol : SM.maybe [] ((\x -> ["-",x]) . original) gamemod) 	showPlayers GameServer{..} = printf "%d / %2d" nplayers slots  browserUpdateOne :: BrowserStore -> GameServer -> IO ()@@ -124,6 +124,6 @@ rememberColumn Bundle{..} n col = do 	order <- treeViewColumnGetSortOrder col 	current <- takeMVar mconfig-	let new = current {browserSort = n, browserOrder = order}+	let new = current {browserSortColumn = n, browserOrder = order} 	putMVar mconfig new 	configToFile parent new
src/ServerInfo.hs view
@@ -112,7 +112,7 @@  		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+		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@@ -156,12 +156,13 @@ 		pid <- maybeIO $ runTremulous config gs (getSettings (address gs) ss) 		case pid of 			Nothing -> do-				gtkError parent $ "Unable to run \"" ++ path ++ "\".\nHave you set your path correctly in Preferences?"+				let msg = case protocolToPath config (protocol gs) of+					Just path -> "Unable to run \"" ++ path ++ "\".\nHave you set your path correctly in Preferences?"+					Nothing   -> "Unknown game (protocol: " ++ show (protocol gs) ++ ")"+				gtkError parent msg 				set join [ widgetSensitive := True ] 				takeMVar running-				where path = case protocol gs of-						70 -> tremGppPath config-						_  -> tremPath config+ 			Just a -> do 				autoSignal mauto AutoPause 				forkIO $ do@@ -171,8 +172,6 @@ 					autoSignal mauto AutoResume 				return () -- 	let updateSettings joining = do 		gs@GameServer{..}	<- readMVar current 		ss			<- readMVar msettings@@ -195,24 +194,24 @@   	on join buttonActivated $ readWithMVar current launchWithSettings-	on st buttonActivated (updateSettings False >> return ())+	on st buttonActivated $ void $ updateSettings False   	let setF boolJoin gs@GameServer{..} = do 		labelSetMarkup hostnamex $ showHostname colors hostname 		zipWithM_ labelSetMarkup info 			[ show address-			, (proto2string protocol ++ (case gamemod of+			, protoToFull protocol ++ (case gamemod of 					SM.Nothing	-> ""-					SM.Just z	-> " (" ++ (unpack . original) z ++ ")"))+					SM.Just z	-> " (" ++ (unpack . original) z ++ ")") 			, maybeS mapname 			, maybeQ timelimit ++ " / " ++ maybeQ suddendeath-			, show slots ++ " (+" ++ maybeQ privslots ++ ")"+			, show slots ++ " (+" ++ show privslots ++ ")" 			, show gameping ++ " / " ++ meanPing players 			, maybeS version 			] 		labelSetText versionLabel (maybeS version)-		labelSetText bools $	unwords	[ if unlagged then "unlagged" else ""+		labelSetText bools $ unwords [ if unlagged then "unlagged" else "" 						, if protected then "password" else "" ]  		listStoreClear amodel@@ -292,15 +291,29 @@ 	maybeS			= SM.maybe "" (unpack . original) 	meanPing		= show . intmean . filter validping . map ping ++protocolToPath :: Config -> Int -> Maybe FilePath+protocolToPath c proto = case proto of+	69 -> Just (tremulousPath c)+	70 -> Just (tremulousGppPath c)+	86 -> Just (unvanquishedPath c)+	_  -> Nothing++ 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 = case protocol of-		70 -> tremGppPath-		_  -> tremPath+runTremulous config GameServer{..} ServerArg{..} =+	case protocolToPath config protocol of+		Just com -> do+			(_,_,_,p) <- createProcess (proc com args) {cwd = ldir, close_fds = True}+			maybe (Just p) (const Nothing) <$> getProcessExitCode p+			where+			ldir = case takeDirectory com of+				"" -> Nothing+				x  -> Just x +		Nothing ->+			return Nothing+	where 	args = concatMap (uncurry arg) 			[ ("connect", show address) 			, ("password", serverPass)@@ -308,10 +321,8 @@ 			, ("name", serverName) 			] -	ldir = case takeDirectory com of-		"" -> Nothing-		x  -> Just x + arg :: String -> String -> [String] arg _ "" = [] arg a s  = ['+':a, s]@@ -324,9 +335,9 @@ 	addColumn gen teamName True [cellTextEllipsize := EllipsizeEnd] $ \rend -> 		cellSetMarkup rend . pangoPrettyBS colors . name 	when showScore $ do-		addColumn gen "Score" False [cellXAlign := 1] $ \rend item -> do+		addColumn gen "Score" False [cellXAlign := 1] $ \rend item -> 			set rend  [cellText := show $ kills item] 		return () 	addColumn gen "Ping" False [cellXAlign := 1] $ \rend item ->-			set rend [ cellText := show $ ping item]+			set rend [cellText := show $ ping item] 	return gen
src/SettingsDialog.hs view
@@ -43,7 +43,7 @@ 		set b	[ entryActivatesDefault := True 			, entryText		:= def 			, entryWidthChars	:= 30 ]-		when (pos == 1 && requirepw) $ do+		when (pos == 1 && requirepw) $ 			labelSetAttributes a [AttrWeight 0 (-1) WeightBold]  		set a	[ labelMnemonicWidget	:= b
− src/System/Environment/XDG/BaseDir.hs 
@@ -1,103 +0,0 @@-{-# LANGUAGE CPP #-}--module System.Environment.XDG.BaseDir-    ( getUserDataDir-    , getUserDataFile-    , getUserConfigDir-    , getUserConfigFile-    , getUserCacheDir-    , getUserCacheFile-    , getSystemDataDirs-    , getSystemDataFiles-    , getSystemConfigDirs-    , getSystemConfigFiles-    , getAllDataDirs-    , getAllDataFiles-    , getAllConfigDirs-    , getAllConfigFiles-    ) where--import System.FilePath    ( (</>), splitSearchPath )-import System.Environment-import System.Directory   ( getHomeDirectory )-import Control.Monad      ( liftM2 )--getDefault :: String -> IO FilePath-#if defined(mingw32_HOST_OS) || defined(__MINGW32__)--getDefault "XDG_DATA_HOME"   = getEnv "AppData"-getDefault "XDG_CONFIG_HOME" = userRelative $ "Local Settings"-getDefault "XDG_CACHE_HOME"  = userRelative $ "Local Settings" </> "Cache"-getDefault "XDG_DATA_DIRS"   = getEnv "ProgramFiles"-getDefault "XDG_CONFIG_DIRS" = getEnv "ProgramFiles"-getDefault _                 = return ""--#else--getDefault "XDG_DATA_HOME"   = userRelative $ ".local" </> "share"-getDefault "XDG_CONFIG_HOME" = userRelative $ ".config"-getDefault "XDG_CACHE_HOME"  = userRelative $ ".cache"-getDefault "XDG_DATA_DIRS"   = return $ "/usr/local/share:/usr/share"-getDefault "XDG_CONFIG_DIRS" = return $ "/etc/xdg"-getDefault _                 = return $ ""--#endif---- | Get the directory for user-specific data files.-getUserDataDir      :: String -> IO FilePath-getUserDataDir      = singleDir "XDG_DATA_HOME"--- | Get the directory for user-specific configuration files.-getUserConfigDir    :: String -> IO FilePath-getUserConfigDir    = singleDir "XDG_CONFIG_HOME"--- | Get the directory for user-specific cache files.-getUserCacheDir     :: String -> IO FilePath-getUserCacheDir     = singleDir "XDG_CACHE_HOME"--- | Get a list of the system-wide data directories.-getSystemDataDirs   :: String -> IO [FilePath]-getSystemDataDirs   = multiDirs "XDG_DATA_DIRS"--- | Get a list of the system-wide configuration directories.-getSystemConfigDirs :: String -> IO [FilePath]-getSystemConfigDirs = multiDirs "XDG_CONFIG_DIRS"--- | Get a list of all data directories.-getAllDataDirs      :: String -> IO [FilePath]-getAllDataDirs a    = liftM2 (:) (getUserDataDir a) (getSystemDataDirs a)--- | Get a list of all configuration directories.-getAllConfigDirs    :: String -> IO [FilePath]-getAllConfigDirs a  = liftM2 (:) (getUserConfigDir a) (getSystemConfigDirs a)--- | Get the path to a specific user data file.-getUserDataFile          :: String -> String -> IO FilePath-getUserDataFile a f      = fmap (</> f) $ getUserDataDir a--- | Get the path to a specific user configuration file.-getUserConfigFile        :: String -> String -> IO FilePath-getUserConfigFile a f    = fmap (</> f) $ getUserConfigDir a--- | Get the path to a specific user cache file.-getUserCacheFile         :: String -> String -> IO FilePath-getUserCacheFile a f     = fmap (</> f) $ getUserCacheDir a--- | Get a list of all paths for a specific system data file.-getSystemDataFiles       :: String -> String -> IO [FilePath]-getSystemDataFiles a f   = fmap (map (</> f)) $ getSystemDataDirs a--- | Get a list of all paths for a specific system configuration file.-getSystemConfigFiles     :: String -> String -> IO [FilePath]-getSystemConfigFiles a f = fmap (map (</> f)) $ getSystemConfigDirs a--- | Get a list of all paths for a specific data file.-getAllDataFiles          :: String -> String -> IO [FilePath]-getAllDataFiles a f      = fmap (map (</> f)) $ getAllDataDirs a--- | Get a list of all paths for a specific configuration file.-getAllConfigFiles        :: String -> String -> IO [FilePath]-getAllConfigFiles a f    = fmap (map (</> f)) $ getAllConfigDirs a--singleDir :: String -> String -> IO FilePath-singleDir key app = envLookup key >>= return . (</> app)--multiDirs :: String -> String -> IO [FilePath]-multiDirs key app = envLookup key >>= return . map (</> app) . splitSearchPath--envLookup :: String -> IO String-envLookup key = do env <- getEnvironment-                   case lookup key env of-                        Just val -> return val-                        Nothing  -> getDefault key--userRelative :: FilePath -> IO FilePath-userRelative p = getHomeDirectory >>= return . (</> p)-
src/Toolbar.hs view
@@ -21,6 +21,7 @@ import ClanFetcher import AutoRefresh + newToolbar :: Bundle -> [ClanHook] -> [PolledHook] -> [ClanPolledHook] -> IO HBox newToolbar bundle@Bundle{..} clanHook polledHook bothHook = do 	c		<- readMVar mconfig@@ -68,9 +69,10 @@ 			[]	| k == "f5" -> liftIO doRefresh		>> return True 			[]	| k == "f6" -> liftIO doSync		>> return True 			[]	| k == "f7" -> liftIO (newAbout parent)	>> return True+			[]	| k == "f8" -> liftIO (toggleButton auto)	>> return True 			_ -> return False -	case (refreshMode c) of+	case refreshMode c of 		Startup	-> doRefresh 		Auto	-> autoSignal mauto AutoStart 		Manual	-> return ()@@ -78,6 +80,9 @@  	return pbrbox +toggleButton :: ToggleButton -> IO ()+toggleButton b = toggleButtonSetActive b . not =<< toggleButtonGetActive b+ -- 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@@ -101,7 +106,7 @@ 	containerAdd button img 	set button	[ buttonRelief		:= ReliefNone 			, buttonFocusOnClick	:= False-			, widgetTooltipText	:= Just "Refresh all servers periodically" ]+			, widgetTooltipText	:= Just "Refresh all servers periodically (F8)" ] 	return button  mLock :: WidgetClass w => w -> (IO () -> IO ()) -> IO (IO ())@@ -119,9 +124,9 @@  newClanSync :: Bundle -> [ClanHook] -> [ClanPolledHook] -> IO () -> IO () newClanSync Bundle{..} clanHook bothHook unlock = do-	Config {clanSyncURL} <- readMVar mconfig+	Config {clanlistURL} <- readMVar mconfig 	forkIO $ do-		new <- getClanList clanSyncURL+		new <- getClanList clanlistURL 		case new of 			Nothing	-> postGUISync $ gtkError parent "Unable to download clanlist" 			Just a	-> do@@ -145,8 +150,8 @@ 	let serversGuess = if serversResponded == 0 then 110 else serversResponded 	let tremTime = (packetDuplication + 1) * packetTimeout 		+ serversGuess * throughputDelay + 200 * 1000--	forkIO $ do+	-- Unmask in case this is called from a masked state+	forkIOWithUnmask $ \un -> un $ do 		hosts <- catMaybes <$> mapM 			(\(host, port, proto) -> fmap (`MasterServer` proto) <$> getDNS host (show port)) 			masterServers
src/TremFormatting.hs view
@@ -1,11 +1,12 @@ module TremFormatting where import Data.Array import Data.Char+import Data.String import Network.Tremulous.NameInsensitive import qualified Data.ByteString.Char8 as B import Data.ByteString.Char8 (ByteString) -data TremFmt = TFColor !String | TFNone !String+data TremFmt = TremFmt {active :: !Bool, color :: !String} 	deriving (Show, Read)  type ColorArray = Array Int TremFmt@@ -25,21 +26,35 @@ pangoPretty arr = pangoColors arr . B.unpack . original  pangoColors :: ColorArray -> String -> String-pangoColors arr = f False where+pangoColors arr = go False where 	--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'-	--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+	go n ('^':x:xs) | isAlphaNum x = close n ++ middle ++ go active xs+		where+		TremFmt {..} = arr ! ((ord x - ord '0') `rem` 8)+		middle	| active	= "<span color=\"" ++ color ++ "\">"+				| otherwise = "" -	f n []		= close n+	-- Escape pango+	go n (x:xs) = case x of+		'<' -> "&lt;" ++ go n xs+		'>' -> "&gt;" ++ go n xs+		'&' -> "&amp;" ++ go n xs+		_   -> x : go n xs +	go n []		= close n+ 	close n = if n then "</span>" else "" +	-- Protocol version+protoToAbbr, protoToFull :: IsString s => Int ->  s+protoToAbbr x = case x of+	69 -> "1.1"+	70 -> "gpp"+	86 -> "unv"+	_  -> "?" +protoToFull x = case x of+	69 -> "Tremulous 1.1"+	70 -> "Tremulous GPP"+	86 -> "Unvanquished"+	_  -> "<Unknown>"