{-# Language OverloadedStrings #-}
{-# Language TemplateHaskell #-}
{-# Language BangPatterns #-}
{-# Language RecordWildCards #-}
module Client.Configuration
(
Configuration(..)
, ConfigurationFailure(..)
, configDefaults
, configServers
, configPalette
, configWindowNames
, configNickPadding
, configConfigPath
, configMacros
, configExtensions
, configExtraHighlights
, loadConfiguration
, resolveConfigurationPath
) where
import Client.Image.Palette
import Client.Configuration.Colors
import Client.Configuration.ServerSettings
import Client.Commands.Interpolation
import Control.Exception
import Control.Monad
import Config
import Config.FromConfig
import Control.Lens hiding (List)
import Data.Foldable (for_)
import Data.HashMap.Strict (HashMap)
import qualified Data.HashMap.Strict as HashMap
import Data.HashSet (HashSet)
import qualified Data.HashSet as HashSet
import Data.Maybe
import Data.Text (Text)
import qualified Data.Text as Text
import qualified Data.Text.IO as Text
import qualified Data.Vector as Vector
import Irc.Identifier (Identifier, mkId)
import System.Directory
import System.FilePath
import System.IO.Error
data Configuration = Configuration
{ _configDefaults :: ServerSettings
, _configServers :: (HashMap Text ServerSettings)
, _configPalette :: Palette
, _configWindowNames :: Text
, _configExtraHighlights :: HashSet Identifier
, _configNickPadding :: Maybe Integer
, _configConfigPath :: Maybe FilePath
, _configMacros :: HashMap Text [[ExpansionChunk]]
, _configExtensions :: [FilePath]
}
deriving Show
makeLenses ''Configuration
data ConfigurationFailure
= ConfigurationParseFailed String
| ConfigurationMalformed String
| ConfigurationReadFailed String
deriving Show
instance Exception ConfigurationFailure
defaultWindowNames :: Text
defaultWindowNames = "1234567890qwertyuiop!@#$%^&*()QWERTYUIOP"
-- | Uses 'getAppUserDataDirectory' to find @.glirc/config@
getOldConfigPath :: IO FilePath
getOldConfigPath =
do dir <- getAppUserDataDirectory "glirc"
return (dir </> "config")
-- | Uses 'getXdgDirectory' 'XdgConfig' to find @.config/glirc/config@
getNewConfigPath :: IO FilePath
getNewConfigPath =
do dir <- getXdgDirectory XdgConfig "glirc"
return (dir </> "config")
-- | Empty configuration file used when no path is specified
-- and the configuration file is missing.
emptyConfigFile :: Text
emptyConfigFile = "{}\n"
-- | Attempt to read a file using the given handler when
-- a file does not exist. On failure a 'ConfigurationReadFailed'
-- exception is throw.
readFileCatchNotFound ::
FilePath {- ^ file to read -} ->
(IOError -> IO Text) {- ^ error handler for not found case -} ->
IO Text
readFileCatchNotFound path onNotFound =
do res <- try (Text.readFile path)
case res of
Left e | isDoesNotExistError e -> onNotFound e
| otherwise -> throwIO (ConfigurationReadFailed (show e))
Right txt -> return txt
-- | Either read a configuration file from one of the default
-- locations, in which case no configuration found is equivalent
-- to an empty configuration, or from the specified file where
-- no configuration found is an error.
readConfigurationFile ::
Maybe FilePath {- ^ just file or use default search paths -} ->
IO Text
readConfigurationFile mbPath =
case mbPath of
Just path ->
readFileCatchNotFound path $ \e ->
throwIO (ConfigurationReadFailed (show e))
Nothing ->
do newPath <- getNewConfigPath
readFileCatchNotFound newPath $ \_ ->
do oldPath <- getOldConfigPath
readFileCatchNotFound oldPath $ \_ ->
return emptyConfigFile
-- | Load the configuration file defaulting to @~/.glirc/config@.
loadConfiguration ::
Maybe FilePath {- ^ path to configuration file -} ->
IO (Either ConfigurationFailure Configuration)
loadConfiguration mbPath = try $
do file <- readConfigurationFile mbPath
def <- loadDefaultServerSettings
rawcfg <-
case parse file of
Left parseError -> throwIO (ConfigurationParseFailed parseError)
Right rawcfg -> return rawcfg
case runConfigParser (parseConfiguration mbPath def rawcfg) of
Left loadError -> throwIO (ConfigurationMalformed (Text.unpack loadError))
Right cfg -> return cfg
parseConfiguration ::
Maybe FilePath {- ^ optionally specified path to config -} ->
ServerSettings {- ^ prepopulated default server settings -} ->
Value ->
ConfigParser Configuration
parseConfiguration _configConfigPath def = parseSections $
do _configDefaults <- fromMaybe def
<$> sectionOptWith (parseServerSettings def) "defaults"
_configServers <- fromMaybe HashMap.empty
<$> sectionOptWith (parseServers _configDefaults) "servers"
_configPalette <- fromMaybe defaultPalette
<$> sectionOptWith parsePalette "palette"
_configWindowNames <- fromMaybe defaultWindowNames
<$> sectionOpt "window-names"
_configMacros <- fromMaybe HashMap.empty
<$> sectionOptWith parseMacroMap "macros"
_configExtensions <- fromMaybe []
<$> sectionOptWith (parseList parseString) "extensions"
_configExtraHighlights <- maybe HashSet.empty HashSet.fromList
<$> sectionOptWith (parseList parseIdentifier) "extra-highlights"
_configNickPadding <- sectionOpt "nick-padding"
for_ _configNickPadding (\padding ->
when (padding < 0)
(liftConfigParser $
failure "nick-padding has to be a non negative number"))
return Configuration{..}
parsePalette :: Value -> ConfigParser Palette
parsePalette = parseSectionsWith paletteHelper defaultPalette
paletteHelper :: Palette -> Text -> Value -> ConfigParser Palette
paletteHelper p k v =
case k of
"nick-colors" -> do xs <- Vector.fromList <$> parseList parseAttr v
when (null xs) (failure "Empty palette")
return $! set palNicks xs p
"self" -> setAttr palSelf
"self-highlight" -> setAttrMb palSelfHighlight
"time" -> setAttr palTime
"meta" -> setAttr palMeta
"sigil" -> setAttr palSigil
"label" -> setAttr palLabel
"latency" -> setAttr palLatency
"error" -> setAttr palError
"textbox" -> setAttr palTextBox
"window-name" -> setAttr palWindowName
"activity" -> setAttr palActivity
"mention" -> setAttr palMention
"command" -> setAttr palCommand
"command-ready" -> setAttr palCommandReady
"command-required" -> setAttr palCommandRequired
"command-optional" -> setAttr palCommandOptional
"command-remaining" -> setAttr palCommandRemaining
_ -> failure "Unknown palette entry"
where
setAttr l =
do !attr <- parseAttr v
return $! set l attr p
setAttrMb l =
do !attr <- parseAttr v
return $! set l (Just attr) p
parseServers :: ServerSettings -> Value -> ConfigParser (HashMap Text ServerSettings)
parseServers def v =
do sss <- parseList (parseServerSettings def) v
return (HashMap.fromList [(serverSettingName ss, ss) | ss <- sss])
where
serverSettingName ss =
fromMaybe (views ssHostName Text.pack ss)
(view ssName ss)
parseServerSettings :: ServerSettings -> Value -> ConfigParser ServerSettings
parseServerSettings = parseSectionsWith parseServerSetting
parseServerSetting :: ServerSettings -> Text -> Value -> ConfigParser ServerSettings
parseServerSetting ss k v =
case k of
"nick" -> setField ssNick
"username" -> setField ssUser
"realname" -> setField ssReal
"userinfo" -> setField ssUserInfo
"password" -> setFieldMb ssPassword
"sasl-username" -> setFieldMb ssSaslUsername
"sasl-password" -> setFieldMb ssSaslPassword
"hostname" -> setFieldWith ssHostName parseString
"port" -> setFieldWithMb ssPort parseNum
"tls" -> setFieldWith ssTls parseUseTls
"tls-client-cert" -> setFieldWithMb ssTlsClientCert parseString
"tls-client-key" -> setFieldWithMb ssTlsClientKey parseString
"server-certificates" -> setFieldWith ssServerCerts (parseList parseString)
"connect-cmds" -> setField ssConnectCmds
"socks-host" -> setFieldWithMb ssSocksHost parseString
"socks-port" -> setFieldWith ssSocksPort parseNum
"chanserv-channels" -> setFieldWith ssChanservChannels (parseList parseIdentifier)
"flood-penalty" -> setField ssFloodPenalty
"flood-threshold" -> setField ssFloodThreshold
"message-hooks" -> setField ssMessageHooks
"name" -> setFieldMb ssName
_ -> failure "Unknown section"
where
setField l = setFieldWith l parseConfig
setFieldMb l = setFieldWithMb l parseConfig
setFieldWith l p =
do x <- p v
return $! set l x ss
setFieldWithMb l p =
do x <- p v
return $! set l (Just x) ss
parseUseTls :: Value -> ConfigParser UseTls
parseUseTls (Atom "yes") = return UseTls
parseUseTls (Atom "yes-insecure") = return UseInsecure
parseUseTls (Atom "no") = return UseInsecure
parseUseTls _ = failure "expected yes, yes-insecure, or no"
parseNum :: Num a => Value -> ConfigParser a
parseNum v = fromInteger <$> parseConfig v
parseIdentifier :: Value -> ConfigParser Identifier
parseIdentifier v = mkId <$> parseConfig v
parseString :: Value -> ConfigParser String
parseString v = Text.unpack <$> parseConfig v
-- | Resolve relative paths starting at the home directory rather than
-- the current directory of the client.
resolveConfigurationPath :: FilePath -> IO FilePath
resolveConfigurationPath path
| isAbsolute path = return path
| otherwise = do home <- getHomeDirectory
return (home </> path)
parseMacroMap :: Value -> ConfigParser (HashMap Text [[ExpansionChunk]])
parseMacroMap v = HashMap.fromList <$> parseList parseMacro v
parseMacro :: Value -> ConfigParser (Text, [[ExpansionChunk]])
parseMacro = parseSections $
do name <- sectionReq "name"
commands <- sectionReqWith (parseList parseMacroCommand) "commands"
return (name, commands)
parseMacroCommand :: Value -> ConfigParser [ExpansionChunk]
parseMacroCommand v =
do txt <- parseConfig v
case parseExpansion txt of
Nothing -> failure "bad macro line"
Just ex -> return ex