module Toolbar where import Graphics.UI.Gtk import Control.Applicative import Control.Exception import Control.Monad import Data.Maybe import Network.Socket import Network.Tremulous.Protocol import Network.Tremulous.Polling import Network.Tremulous.Scheduler (getMicroTime) import Types import Constants import STM2 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) newToolbar :: Bundle -> IO () -> IO () -> IO HBox newToolbar bundle@Bundle{..} clanHook polledHook = do pbrbox <- hBoxNew False spacing 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 ] on about buttonActivated $ newAbout parent (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 about 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=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 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 result <- pollMasters delays hosts atomically $ replaceTMVar mpolled result killThread pbth postGUISync $ do polledHook refresh `set` [ widgetSensitive := True ] widgetHide pb return () on refresh buttonActivated serverRefresh Config {..} <- atomically $ readTMVar mconfig when autoMaster serverRefresh when autoClan doSync return pbrbox