diff --git a/apelsin.cabal b/apelsin.cabal --- a/apelsin.cabal +++ b/apelsin.cabal @@ -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 diff --git a/src/About.hs b/src/About.hs --- a/src/About.hs +++ b/src/About.hs @@ -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 " , aboutDialogComments := "A tremulous server and community browser\nLicense: GPLv3" , aboutDialogWebsite := "http://ojeling.net" diff --git a/src/Apelsin.hs b/src/Apelsin.hs --- a/src/Apelsin.hs +++ b/src/Apelsin.hs @@ -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"] diff --git a/src/AutoRefresh.hs b/src/AutoRefresh.hs new file mode 100644 --- /dev/null +++ b/src/AutoRefresh.hs @@ -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 () diff --git a/src/ClanFetcher.hs b/src/ClanFetcher.hs --- a/src/ClanFetcher.hs +++ b/src/ClanFetcher.hs @@ -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 = "*" - 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)) diff --git a/src/Clanlist.hs b/src/Clanlist.hs --- a/src/Clanlist.hs +++ b/src/Clanlist.hs @@ -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{..} -> "" ++ htmlEscape (unpackorig name) ++ "" - 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 diff --git a/src/ConcurrentUtil.hs b/src/ConcurrentUtil.hs new file mode 100644 --- /dev/null +++ b/src/ConcurrentUtil.hs @@ -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 () diff --git a/src/Config.hs b/src/Config.hs --- a/src/Config.hs +++ b/src/Config.hs @@ -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 "" diff --git a/src/Constants.hs b/src/Constants.hs --- a/src/Constants.hs +++ b/src/Constants.hs @@ -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 diff --git a/src/Exception2.hs b/src/Exception2.hs new file mode 100644 --- /dev/null +++ b/src/Exception2.hs @@ -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) diff --git a/src/FilterBar.hs b/src/FilterBar.hs --- a/src/FilterBar.hs +++ b/src/FilterBar.hs @@ -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 + + diff --git a/src/FindPlayers.hs b/src/FindPlayers.hs --- a/src/FindPlayers.hs +++ b/src/FindPlayers.hs @@ -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 diff --git a/src/GtkExts.hs b/src/GtkExts.hs --- a/src/GtkExts.hs +++ b/src/GtkExts.hs @@ -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 () diff --git a/src/GtkUtils.hs b/src/GtkUtils.hs --- a/src/GtkUtils.hs +++ b/src/GtkUtils.hs @@ -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 diff --git a/src/IndividualServerSettings.hs b/src/IndividualServerSettings.hs new file mode 100644 --- /dev/null +++ b/src/IndividualServerSettings.hs @@ -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 diff --git a/src/InfoBox.hs b/src/InfoBox.hs --- a/src/InfoBox.hs +++ b/src/InfoBox.hs @@ -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] diff --git a/src/List2.hs b/src/List2.hs --- a/src/List2.hs +++ b/src/List2.hs @@ -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) diff --git a/src/Monad2.hs b/src/Monad2.hs new file mode 100644 --- /dev/null +++ b/src/Monad2.hs @@ -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) diff --git a/src/NumberSerializer.hs b/src/NumberSerializer.hs new file mode 100644 --- /dev/null +++ b/src/NumberSerializer.hs @@ -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)) diff --git a/src/OnlineClans.hs b/src/OnlineClans.hs new file mode 100644 --- /dev/null +++ b/src/OnlineClans.hs @@ -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 ["", htmlEscapeBS $ original name, ""] + 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)) diff --git a/src/Preferences.hs b/src/Preferences.hs --- a/src/Preferences.hs +++ b/src/Preferences.hs @@ -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) diff --git a/src/STM2.hs b/src/STM2.hs deleted file mode 100644 --- a/src/STM2.hs +++ /dev/null @@ -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) diff --git a/src/ServerBrowser.hs b/src/ServerBrowser.hs --- a/src/ServerBrowser.hs +++ b/src/ServerBrowser.hs @@ -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 diff --git a/src/ServerInfo.hs b/src/ServerInfo.hs --- a/src/ServerInfo.hs +++ b/src/ServerInfo.hs @@ -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 = "" ++ x ++ "" - showHostname colors x = formatHostname $ case pangoPretty colors x of - "" -> "Invalid name" - a -> a - maybeQ = maybe "?" show + showHostname _ (TI _ "") = "Invalid name" + 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 diff --git a/src/SettingsDialog.hs b/src/SettingsDialog.hs new file mode 100644 --- /dev/null +++ b/src/SettingsDialog.hs @@ -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 + diff --git a/src/Toolbar.hs b/src/Toolbar.hs --- a/src/Toolbar.hs +++ b/src/Toolbar.hs @@ -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 () diff --git a/src/TremFormatting.hs b/src/TremFormatting.hs --- a/src/TremFormatting.hs +++ b/src/TremFormatting.hs @@ -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 - '<' -> "<" ++ xs - '>' -> ">" ++ xs - '&' -> "&" ++ xs - _ -> x : xs - +htmlEscapeBS :: ByteString -> ByteString +htmlEscapeBS = B.concat . B.foldr f [] where + f x xs = case x of + '<' -> "<" : xs + '>' -> ">" : xs + '&' -> "&" : 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 ++ "" ++ 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 + '<' -> "<" ++ f n xs + '>' -> ">" ++ f n xs + '&' -> "&" ++ f n xs + _ -> x : f n xs + f n [] = close n - + close n = if n then "" else "" -pangoPretty :: ColorArray-> TI -> String -pangoPretty arr = pangoColors arr . htmlEscape . unpackorig + diff --git a/src/Types.hs b/src/Types.hs --- a/src/Types.hs +++ b/src/Types.hs @@ -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