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