apelsin-1.2: src/Config.hs

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 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
	, refreshMode	:: !RefreshMode
	, autoClan
	, autoGeometry	:: !Bool
	, autoDelay	:: !MicroTime
	, filterBrowser
	, filterPlayers	:: !String
	, filterEmpty	:: !Bool
	, browserSort
	, playersSort
	, clanlistSort	:: !Int
	, browserOrder
	, playersOrder
	, clanlistOrder	:: !SortType
	, delays	:: !Delay
	, colors	:: !ColorTheme
	}


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 :: Window -> Config -> IO ()
configToFile win config = do
	file <- inConfDir "config"
	handle err $ do
	writeFile file (newSave config)
	where
	err (e::IOError) = gtkWarn win $ "Unable to save settings:\n" ++ show e


configFromFile :: IO Config
configFromFile = handle err $ do
	file	<- inConfDir "config"
	cont	<- readFile file
	return $ parse cont
	where
	err (_::IOError) = return $ parse ""