{-# LANGUAGE BangPatterns #-}
{-# LANGUAGE OverloadedStrings #-}
{-# LANGUAGE RecordWildCards #-}
{-# LANGUAGE TemplateHaskell #-}
{-# LANGUAGE ApplicativeDo #-}
module Client.Configuration
(
Configuration(..)
, ConfigurationFailure(..)
, LayoutMode(..)
, PaddingMode(..)
, configDefaults
, configServers
, configPalette
, configWindowNames
, configNickPadding
, configMacros
, configExtensions
, configExtraHighlights
, configUrlOpener
, configIgnores
, configActivityBar
, configBellOnMention
, configHideMeta
, configKeyMap
, configLayout
, configShowPing
, configJumpModifier
, loadConfiguration
, getNewConfigPath
, configurationSpec
) where
import Client.Commands.Interpolation
import Client.Commands.Recognizer
import Client.Configuration.Colors
import Client.Configuration.Macros (macroMapSpec)
import Client.Configuration.ServerSettings
import Client.EventLoop.Actions
import Client.Image.Palette
import Config
import Config.Schema
import Control.Exception
import Control.Lens hiding (List)
import Data.Foldable (toList, find)
import Data.Functor.Alt ((<!>))
import Data.HashMap.Strict (HashMap)
import qualified Data.HashMap.Strict as HashMap
import Data.HashSet (HashSet)
import qualified Data.HashSet as HashSet
import qualified Data.List.NonEmpty as NonEmpty
import Data.Maybe
import Data.Monoid (Endo(..), (<>))
import Data.Text (Text)
import qualified Data.Text as Text
import qualified Data.Text.IO as Text
import qualified Data.Vector as Vector
import Graphics.Vty.Input.Events (Modifier(..), Key(..))
import Irc.Identifier (Identifier)
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 :: PaddingMode
, _configMacros :: Recognizer Macro
, _configExtensions :: [FilePath]
, _configUrlOpener :: Maybe FilePath
, _configIgnores :: [Text]
, _configActivityBar :: Bool
, _configBellOnMention :: Bool
, _configHideMeta :: Bool
, _configKeyMap :: KeyMap
, _configLayout :: LayoutMode
, _configShowPing :: Bool
, _configJumpModifier :: [Modifier]
}
deriving Show
data PaddingMode
= LeftPadding !Int
| RightPadding !Int
| NoPadding
deriving (Show)
data LayoutMode
= OneColumn
| TwoColumn
deriving Show
makeLenses ''Configuration
data ConfigurationFailure
= ConfigurationReadFailed String
| ConfigurationParseFailed FilePath String
| ConfigurationMalformed FilePath String
deriving Show
instance Exception ConfigurationFailure
defaultWindowNames :: Text
defaultWindowNames = "1234567890qwertyuiop!@#$%^&*()QWERTYUIOP"
getOldConfigPath :: IO FilePath
getOldConfigPath =
do dir <- getAppUserDataDirectory "glirc"
return (dir </> "config")
getNewConfigPath :: IO FilePath
getNewConfigPath =
do dir <- getXdgDirectory XdgConfig "glirc"
return (dir </> "config")
emptyConfigFile :: Text
emptyConfigFile = "{}\n"
readFileCatchNotFound ::
FilePath ->
(IOError -> IO (FilePath, Text)) ->
IO (FilePath, 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 (path, txt)
readConfigurationFile ::
Maybe FilePath ->
IO (FilePath, 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)
loadConfiguration ::
Maybe FilePath ->
IO (Either ConfigurationFailure Configuration)
loadConfiguration mbPath = try $
do (path,txt) <- readConfigurationFile mbPath
def <- loadDefaultServerSettings
rawcfg <-
case parse txt of
Left e -> throwIO (ConfigurationParseFailed path (displayException e))
Right rawcfg -> return rawcfg
case loadValue configurationSpec rawcfg of
Left es -> throwIO
$ ConfigurationMalformed path
$ Text.unpack
$ Text.unlines
$ map explainLoadError (toList es)
Right cfg -> resolvePaths path (cfg def)
explainLoadError :: LoadError Position -> Text
explainLoadError (LoadError pos path problem) =
Text.concat [ positionText, " at ", pathText, ": ", problemText]
where
positionText =
Text.unwords ["line" , Text.pack (show (posLine pos)),
"column", Text.pack (show (posColumn pos))]
pathText
| null path = "top-level"
| otherwise = Text.intercalate ":" path
problemText =
case problem of
UnusedSection s -> "unknown section `" <> s <> "`"
MissingSection s -> "missing required section `" <> s <> "`"
SpecMismatch t -> "expected " <> t
resolvePaths :: FilePath -> Configuration -> IO Configuration
resolvePaths file cfg =
do res <- resolveFilePath <$> newFilePathContext file
let resolveServerFilePaths = over (ssTlsClientCert . mapped) res
. over (ssTlsClientKey . mapped) res
. over (ssTlsServerCert . mapped) res
. over (ssSaslEcdsaFile . mapped) res
. over (ssLogDir . mapped) res
return $! over (configExtensions . mapped) res
. over (configServers . mapped) resolveServerFilePaths
$ cfg
configurationSpec ::
ValueSpecs (ServerSettings -> Configuration)
configurationSpec = sectionsSpec "" $
do let sec' def name spec info = fromMaybe def <$> optSection' name spec info
identifierSetSpec = HashSet.fromList <$> listSpec identifierSpec
ssDefUpdate <- sec' id "defaults" serverSpec
"Default values for use across all server configurations"
ssUpdates <- sec' [] "servers" (listSpec serverSpec)
"Configuration parameters for IRC servers"
_configPalette <- sec' defaultPalette "palette" paletteSpec
"Customize the client color choices"
_configWindowNames <- sec' defaultWindowNames "window-names" valuesSpec
"Window names to use for quick jumping with jump-modifier key"
_configJumpModifier <- sec' [MMeta] "jump-modifier" modifierSpec
"Modifier used to jump to a window by name. Defaults to `meta`."
_configMacros <- sec' mempty "macros" macroMapSpec
"Programmable macro commands"
_configExtensions <- sec' [] "extensions" (listSpec stringSpec)
"Filenames of extension libraries to load at startup"
_configUrlOpener <- optSection' "url-opener" stringSpec
"External command used by /url command"
_configExtraHighlights <- sec' mempty "extra-highlights" identifierSetSpec
"Extra words to highlight in chat messages"
_configNickPadding <- sec' NoPadding "nick-padding" nickPaddingSpec
"Amount of space to reserve for nicknames in chat messages"
_configIgnores <- sec' [] "ignores" valuesSpec
"Set of nicknames to ignore on startup"
_configActivityBar <- sec' False "activity-bar" yesOrNoSpec
"Show channel names and message counts for activity on\
\ unfocused channels."
_configBellOnMention <- sec' False "bell-on-mention" yesOrNoSpec
"Emit bell character to terminal on mention"
_configHideMeta <- sec' False "hide-metadata" yesOrNoSpec
"Initial setting for hiding metadata on new windows"
bindings <- sec' [] "key-bindings" (listSpec keyBindingSpec)
"Extra key bindings"
_configLayout <- sec' OneColumn "layout" layoutSpec
"Initial setting for window layout"
_configShowPing <- sec' True "show-ping" yesOrNoSpec
"Initial setting for visibility of ping times"
return (\def ->
let _configDefaults = ssDefUpdate def
_configServers = buildServerMap _configDefaults ssUpdates
_configKeyMap = foldl (\acc f -> f acc) initialKeyMap bindings
in Configuration{..})
defaultPaddingSide :: Int -> PaddingMode
defaultPaddingSide = RightPadding
nickPaddingSpec :: ValueSpecs PaddingMode
nickPaddingSpec = defaultPaddingSide <$> nonnegativeSpec <!> fullNickPaddingSpec
fullNickPaddingSpec :: ValueSpecs PaddingMode
fullNickPaddingSpec = sectionsSpec "nick-padding" (sideSec <*> amtSec)
where
sideSpec = LeftPadding <$ atomSpec "left" <!>
RightPadding <$ atomSpec "right"
sideSec = fromMaybe defaultPaddingSide
<$> optSection' "side" sideSpec "Side to pad (default `right`)"
amtSec = reqSection' "width" nonnegativeSpec "Field width"
modifierSpec :: ValueSpecs [Modifier]
modifierSpec = toList <$> oneOrNonemptySpec modifier1Spec
where
modifier1Spec = namedSpec "modifier"
$ MMeta <$ atomSpec "meta"
<!> MAlt <$ atomSpec "alt"
<!> MCtrl <$ atomSpec "ctrl"
layoutSpec :: ValueSpecs LayoutMode
layoutSpec = OneColumn <$ atomSpec "one-column"
<!> TwoColumn <$ atomSpec "two-column"
keyBindingSpec :: ValueSpecs (KeyMap -> KeyMap)
keyBindingSpec = actBindingSpec <!> cmdBindingSpec <!> unbindingSpec
actBindingSpec :: ValueSpecs (KeyMap -> KeyMap)
actBindingSpec = sectionsSpec "action-binding" $
do ~(m,k) <- reqSection' "bind" keySpec
"Key to be bound (e.g. a, C-b, M-c C-M-d)"
a <- reqSection "action"
"Action name (see `/keymap`)"
return (addKeyBinding m k a)
cmdBindingSpec :: ValueSpecs (KeyMap -> KeyMap)
cmdBindingSpec = sectionsSpec "command-binding" $
do ~(m,k) <- reqSection' "bind" keySpec
"Key to be bound (e.g. a, C-b, M-c C-M-d)"
cmd <- reqSection "command"
"Client command to execute (exclude leading `/`)"
return (addKeyBinding m k (ActCommand cmd))
unbindingSpec :: ValueSpecs (KeyMap -> KeyMap)
unbindingSpec = sectionsSpec "remove-binding" $
do ~(m,k) <- reqSection' "unbind" keySpec
"Key to be unbound (e.g. a, C-b, M-c C-M-d)"
return (removeKeyBinding m k)
keySpec :: ValueSpecs ([Modifier], Key)
keySpec = customSpec "emacs-key" stringSpec parseKey
nonnegativeSpec :: (Ord a, Num a) => ValueSpecs a
nonnegativeSpec = customSpec "non-negative" numSpec $ \x -> find (0 <=) [x]
paletteSpec :: ValueSpecs Palette
paletteSpec = sectionsSpec "palette" $
(ala Endo (foldMap . foldMap) ?? defaultPalette) <$> sequenceA fields
where
nickColorsSpec = set palNicks . Vector.fromList . NonEmpty.toList <$> nonemptySpec attrSpec
fields :: [SectionSpecs (Maybe (Palette -> Palette))]
fields = optSection' "nick-colors" nickColorsSpec
"Colors used to highlight nicknames"
: [ optSection' lbl (set l <$> attrSpec) "" | (lbl, Lens l) <- paletteMap ]
buildServerMap ::
ServerSettings ->
[ServerSettings -> ServerSettings] ->
HashMap Text ServerSettings
buildServerMap def ups =
HashMap.fromList [ (serverSettingName ss, ss) | up <- ups, let ss = up def ]
where
serverSettingName ss =
fromMaybe (views ssHostName Text.pack ss)
(view ssName ss)
data FilePathContext = FilePathContext { fpBase, fpHome :: FilePath }
newFilePathContext ::
FilePath ->
IO FilePathContext
newFilePathContext base = FilePathContext (takeDirectory base) <$> getHomeDirectory
resolveFilePath :: FilePathContext -> FilePath -> FilePath
resolveFilePath fpc path
| isAbsolute path = path
| "~":rest <- splitDirectories path = joinPath (fpHome fpc : rest)
| otherwise = fpBase fpc </> path