matsuri-0.0.4: Config.hs

-- | Config.hs
-- Config file reading; functions for working with config structure.

module Config (
    Config,
    readConfig,
    getCF,
    setCF
) where

import Buffers
import Help

import Data.ConfigFile
import qualified Data.Map as M
import System.Directory
import Control.Monad.Error
import Control.OldException
import Data.List


type Config = M.Map OptionSpec String

-- | Default config. If no value in config file, then default value
-- will be used.
defaultConfig = [ ("client", "matsuri")
                , ("version", "0.0.x")
                , ("OS", "LEENOOPS OS")
                , ("roster_width", "20")
                , ("show_roster", "1")
                , ("default_group", "other")
                , ("conferences_group", "conferences")
                ]


-- | Reading "main" and "account_*" sections of config file.
readConfig :: FilePath -> IO (Config, Buffers)
readConfig filePath = do
    home <- getHomeDirectory
    fileCnt <- handle (\_ -> error help_noconfig)
                      (readFile (home++"/"++filePath))
    confs <- runErrorT $ do
        conf <- readstring emptyCP fileCnt

        -- reading and updating main options
        mainOptions <- items conf "main"
        let def_conf = M.fromList defaultConfig
            config = foldr updateValue def_conf mainOptions

        -- reading account_* sections
        let sects' = filter ("account_" `isPrefixOf`) (sections conf)
            sects | length sects' == 0 = configError "no accounts"
                  | otherwise          = sects'
            readAcc acc = liftM2 (,) (return $ drop 8 acc) (items conf acc)

        liftM2 (,)
            (return config)
            (mapM readAcc sects >>= return . foldr doAccount M.empty)
    case confs of
        Left _ -> configError "wrong format"
        Right conf -> return conf

-- | Update option's value or exit with error if find unknown option.
updateValue :: (OptionSpec, String) -> Config -> Config
updateValue (option, value) config =
    let (value', config') = M.updateLookupWithKey
                                (\_ _ -> Just value)
                                option
                                config
    in case value' of
         Just _ -> config'
         Nothing -> if "alias " `isPrefixOf` option
                    then M.insert option value config
                    else configError ("unknown `"++option++"' option")

-- | Insert new account in buffer or exit with error if wrong options.
doAccount :: (String, [(OptionSpec, String)]) -> Buffers -> Buffers
doAccount (accountName, accountOpts) =
    M.insert
        accountName
        (BufAccount Account
          { accName = accountName
          , username = username'
          , server = findOpt "server"
          , password = findOpt "password"
          , resource = resource'
          , priority = priority'
          , defaultNick = defaultNick'
          , connection = NoConnection
          , accCollapsed = False
          , accContents = []
          })
    where
      username' = findOpt "username"
      resource' = maybe "matsuri" snd $ findOpt' "resource"
      priority' = maybe 0 (read . snd) $ findOpt' "priority"
      defaultNick' = maybe username' snd $ findOpt' "nick"

      findOpt opt = maybe (noOpt opt) snd $ findOpt' opt
      findOpt' optName = find (\(name, _) -> name == optName) accountOpts
      noOpt opt = configError ("can't find `'"++opt++"' option\
                               \ for `"++accountName++"' account")

configError err = error ("can't read config file ("++err++")")


getCF :: String -> Config -> String
getCF k = maybe "" id . M.lookup k

setCF :: String -> String -> Config -> Config
setCF k v = M.adjust (const v) k