diff --git a/ChangeLog.md b/ChangeLog.md --- a/ChangeLog.md +++ b/ChangeLog.md @@ -1,5 +1,10 @@ # Revision history for glirc2 +## 2.20.6 + +* Switch to new `config-schema` package for configuration file loading. +* Add `--config-format` flag to executable to show configuration file format. + ## 2.20.5 * Add line indicating message since previous time window was focused. diff --git a/exec/Main.hs b/exec/Main.hs --- a/exec/Main.hs +++ b/exec/Main.hs @@ -57,7 +57,7 @@ Left (ConfigurationParseFailed e) -> report "Failed to parse configuration:" e Left (ConfigurationMalformed e) -> - report "Configuration malformed: " e + report "Configuration malformed (try --config-format): " e where report problem msg = do hPutStrLn stderr problem diff --git a/glirc.cabal b/glirc.cabal --- a/glirc.cabal +++ b/glirc.cabal @@ -1,5 +1,5 @@ name: glirc -version: 2.20.5 +version: 2.20.6 synopsis: Console IRC client description: Console IRC client . @@ -23,9 +23,9 @@ tested-with: GHC==8.0.2 custom-setup - setup-depends: base >=4.9 && <4.11, - filepath >1.4 && <1.5, - Cabal >=1.24 && <3 + setup-depends: base >=4.9 && <4.11, + filepath >=1.4 && <1.5, + Cabal >=1.24 && <3 source-repository head type: git @@ -111,7 +111,6 @@ Client.View.UrlSelection Client.View.UserList Client.View.Windows - Config.FromConfig other-modules: LensUtils StrictUnit @@ -125,6 +124,7 @@ bytestring >=0.10.8 && <0.11, base64-bytestring >=1.0.0.1 && <1.1, config-value >=0.5 && <0.6, + config-schema >=0.1 && <0.2, containers >=0.5.7 && <0.6, directory >=1.2.6 && <1.4, filepath >=1.4.1 && <1.5, @@ -137,6 +137,7 @@ network >=2.6.2 && <2.7, process >=1.4.2 && <1.7, regex-tdfa >=1.2 && <1.3, + semigroupoids >=5.2 && <5.3, socks >=0.5.5 && <0.6, split >=0.2 && <0.3, stm >=2.4 && <2.5, diff --git a/src/Client/Commands.hs b/src/Client/Commands.hs --- a/src/Client/Commands.hs +++ b/src/Client/Commands.hs @@ -1048,7 +1048,7 @@ -- | Tab completion for @/splits-@. This completes only from the list of active -- entries in the splits list. tabActiveSplits :: Bool -> ClientCommand String -tabActiveSplits isReversed st rest = +tabActiveSplits isReversed st _ = simpleTabCompletion plainWordCompleteMode [] completions isReversed st where completions = renderFocus <$> view clientExtraFocus st diff --git a/src/Client/Configuration.hs b/src/Client/Configuration.hs --- a/src/Client/Configuration.hs +++ b/src/Client/Configuration.hs @@ -2,6 +2,7 @@ {-# LANGUAGE OverloadedStrings #-} {-# LANGUAGE RecordWildCards #-} {-# LANGUAGE TemplateHaskell #-} +{-# LANGUAGE ApplicativeDo #-} {-| Module : Client.Configuration @@ -40,6 +41,9 @@ -- * Resolving paths , resolveConfigurationPath + + -- * Specification + , configurationSpec ) where import Client.Commands.Interpolation @@ -49,11 +53,12 @@ import Client.Configuration.ServerSettings import Client.Image.Palette import Config -import Config.FromConfig +import Config.Schema +import Control.Applicative import Control.Exception import Control.Lens hiding (List) -import Control.Monad -import Data.Foldable (for_) +import Data.Foldable (find, foldl') +import Data.Functor.Alt (()) import Data.HashMap.Strict (HashMap) import qualified Data.HashMap.Strict as HashMap import Data.HashSet (HashSet) @@ -61,6 +66,7 @@ import Data.List.NonEmpty (NonEmpty) import qualified Data.List.NonEmpty as NonEmpty import Data.Maybe +import Data.Monoid ((<>)) import Data.Text (Text) import qualified Data.Text as Text import qualified Data.Text.IO as Text @@ -179,158 +185,170 @@ 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 + case loadValue configurationSpec rawcfg of + Left es -> throwIO + $ ConfigurationMalformed + $ Text.unpack + $ Text.unlines $ map explainLoadError es + Right cfg -> return (cfg mbPath def) -parseConfiguration :: - Maybe FilePath {- ^ optionally specified path to config -} -> - ServerSettings {- ^ prepopulated default server settings -} -> - Value -> - ConfigParser Configuration -parseConfiguration _configConfigPath def = parseSections $ +explainLoadError :: LoadError -> Text +explainLoadError (LoadError path problem) = + Text.intercalate "." path <> ": " <> + case problem of + UnusedSections xs -> "Unknown sections: " <> Text.intercalate ", " xs + MissingSection s -> "Missing required section: " <> s + SpecMismatch s -> "Expected " <> s - do _configDefaults <- fromMaybe def - <$> sectionOptWith (parseServerSettings def) "defaults" - _configServers <- fromMaybe HashMap.empty - <$> sectionOptWith (parseServers _configDefaults) "servers" +configurationSpec :: ValueSpecs (Maybe FilePath -> ServerSettings -> Configuration) +configurationSpec = sectionsSpec "" $ + do ssDefUpdate <- fromMaybe id <$> optSection' "defaults" "" serverSpec + ssUpdates <- fromMaybe [] <$> optSection' "servers" "" (listSpec serverSpec) + _configPalette <- fromMaybe defaultPalette - <$> sectionOptWith parsePalette "palette" + <$> optSection' "palette" "" paletteSpec _configWindowNames <- fromMaybe defaultWindowNames - <$> sectionOpt "window-names" + <$> optSection "window-names" "" _configMacros <- fromMaybe mempty - <$> sectionOptWith parseMacroMap "macros" + <$> optSection' "macros" "" macroMapSpec - _configExtensions <- fromMaybe [] - <$> sectionOptWith (parseList parseString) "extensions" + _configExtensions <- fromMaybe [] <$> optSection' "extensions" "" (listSpec stringSpec) - _configUrlOpener <- sectionOptWith parseString "url-opener" + _configUrlOpener <- optSection' "url-opener" "" stringSpec - _configExtraHighlights <- maybe HashSet.empty HashSet.fromList - <$> sectionOptWith (parseList parseIdentifier) "extra-highlights" + _configExtraHighlights <- maybe HashSet.empty (HashSet.fromList . map mkId) + <$> optSection "extra-highlights" "" - _configNickPadding <- sectionOpt "nick-padding" + _configNickPadding <- optSection' "nick-padding" "" nonnegativeSpec - _configIndentWrapped <- sectionOpt "indent-wrapped-lines" + _configIndentWrapped <- optSection' "indent-wrapped-lines" "" nonnegativeSpec - _configIgnores <- maybe HashSet.empty HashSet.fromList - <$> sectionOptWith (parseList parseIdentifier) "ignores" + _configIgnores <- maybe HashSet.empty (HashSet.fromList . map mkId) + <$> optSection "ignores" "" - _configActivityBar <- fromMaybe False <$> sectionOpt "activity-bar" + _configActivityBar <- fromMaybe False + <$> optSection' "activity-bar" "" yesOrNoSpec - _configBellOnMention <- fromMaybe False <$> sectionOpt "bell-on-mention" + _configBellOnMention <- fromMaybe False <$> optSection' "bell-on-mention" "" yesOrNoSpec - for_ _configNickPadding (\padding -> - when (padding < 0) - (liftConfigParser $ - failure "nick-padding has to be a non negative number")) + return (\_configConfigPath def -> + let _configDefaults = ssDefUpdate def + _configServers = buildServerMap _configDefaults ssUpdates + in Configuration{..}) - for_ _configIndentWrapped (\indent -> - when (indent < 0) - (liftConfigParser $ - failure "indent-wrapped-lines has to be a non negative number")) - return Configuration{..} +nonnegativeSpec :: (Ord a, Num a) => ValueSpecs a +nonnegativeSpec = customSpec "non-negative" numSpec $ \x -> find (0 <=) [x] -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 - _ | Just (Lens l) <- lookup k paletteMap -> - do !attr <- parseAttr v - return $! set l attr p - _ -> failure "Unknown palette entry" +paletteSpec :: ValueSpecs Palette +paletteSpec = sectionsSpec "palette" $ + do updates <- catMaybes <$> sequenceA + [ fmap (set l) <$> optSection' lbl "" attrSpec | (lbl, Lens l) <- paletteMap ] + nickColors <- optSection' "nick-colors" "" (nonemptyList attrSpec) + return (let pal1 = foldl' (\acc f -> f acc) defaultPalette updates + in case nickColors of + Nothing -> pal1 + Just xs -> set palNicks (Vector.fromList (NonEmpty.toList xs)) pal1) -parseServers :: ServerSettings -> Value -> ConfigParser (HashMap Text ServerSettings) -parseServers def v = - do sss <- parseList (parseServerSettings def) v - return (HashMap.fromList [(serverSettingName ss, ss) | ss <- sss]) +nonemptyList :: ValueSpecs a -> ValueSpecs (NonEmpty a) +nonemptyList s = customSpec "non-empty" (listSpec s) NonEmpty.nonEmpty + + +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) -parseServerSettings :: ServerSettings -> Value -> ConfigParser ServerSettings -parseServerSettings = parseSectionsWith parseServerSetting - -parseServerSetting :: ServerSettings -> Text -> Value -> ConfigParser ServerSettings -parseServerSetting ss k v = - case k of - "nick" -> setFieldWith ssNicks parseNicks - "username" -> setField ssUser - "realname" -> setField ssReal - "userinfo" -> setField ssUserInfo - "password" -> setFieldMb ssPassword - "sasl-username" -> setFieldMb ssSaslUsername - "sasl-password" -> setFieldMb ssSaslPassword - "sasl-ecdsa-key" -> setFieldWithMb ssSaslEcdsaFile parseString - "hostname" -> setFieldWith ssHostName parseString - "port" -> setFieldWithMb ssPort parseNum - "tls" -> setFieldWith ssTls parseUseTls - "tls-client-cert" -> setFieldWithMb ssTlsClientCert parseString - "tls-client-key" -> setFieldWithMb ssTlsClientKey parseString - "tls-server-cert" -> setFieldWithMb ssTlsServerCert parseString - "tls-ciphers" -> setFieldWith ssTlsCiphers parseString - "connect-cmds" -> setFieldWith ssConnectCmds (parseList parseMacroCommand) - "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 - "reconnect-attempts" -> setField ssReconnectAttempts - "autoconnect" -> setField ssAutoconnect - "nick-completion" -> setFieldWith ssNickCompletion parseNickCompletion - "log-dir" -> setFieldWithMb ssLogDir parseString - _ -> failure "Unknown setting" +serverSpec :: ValueSpecs (ServerSettings -> ServerSettings) +serverSpec = sectionsSpec "server-settings" $ + do updates <- catMaybes <$> sequenceA settings + return (foldr (.) id updates) where - setField l = setFieldWith l parseConfig - setFieldMb l = setFieldWithMb l parseConfig + req l s = set l <$> s - setFieldWith l p = - do x <- p v - return $! set l x ss + opt l s = set l . Just <$> s + set l Nothing <$ atomSpec "clear" - setFieldWithMb l p = - do x <- case v of - Atom "clear" -> return Nothing - _ -> Just <$> p v - return $! set l x ss + settings = + [ optSection' "name" "The name used to identify this server in the client" + $ opt ssName valuesSpec + , optSection' "hostname" "Hostname of server" + $ req ssHostName stringSpec + , optSection' "port" "Port number of server. Default 6667 without TLS or 6697 with TLS" + $ opt ssPort numSpec + , optSection' "nick" "Nicknames to connect with in order" + $ req ssNicks nicksSpec + , optSection' "password" "Server password" + $ opt ssPassword valuesSpec + , optSection' "username" "Second component of _!_@_ usermask" + $ req ssUser valuesSpec + , optSection' "realname" "\"GECOS\" name sent to server visible in /whois" + $ req ssReal valuesSpec + , optSection' "userinfo" "CTCP userinfo (currently unused)" + $ req ssUserInfo valuesSpec + , optSection' "sasl-username" "Username for SASL authentication to NickServ" + $ opt ssSaslUsername valuesSpec + , optSection' "sasl-password" "Password for SASL authentication to NickServ" + $ opt ssSaslPassword valuesSpec + , optSection' "sasl-ecdsa-key" "Path to ECDSA key for non-password SASL authentication" + $ opt ssSaslEcdsaFile stringSpec + , optSection' "tls" "Set to `yes` to enable secure connect. Set to `yes-insecure` to disable certificate checking." + $ req ssTls useTlsSpec + , optSection' "tls-client-cert" "Path to TLS client certificate" + $ opt ssTlsClientCert stringSpec + , optSection' "tls-client-key" "Path to TLS client key" + $ opt ssTlsClientKey stringSpec + , optSection' "tls-server-cert" "Path to CA certificate bundle" + $ opt ssTlsServerCert stringSpec + , optSection' "tls-ciphers" "OpenSSL cipher specification. Default to \"HIGH\"" + $ req ssTlsCiphers stringSpec + , optSection' "socks-host" "Hostname of SOCKS5 proxy server" + $ opt ssSocksHost stringSpec + , optSection' "socks-port" "Port number of SOCKS5 proxy server" + $ req ssSocksPort numSpec + , optSection' "connect-cmds" "Command to be run upon successful connection to server" + $ req ssConnectCmds $ listSpec macroCommandSpec + , optSection' "chanserv-channels" "Channels with ChanServ permissions available" + $ req ssChanservChannels $ listSpec identifierSpec + , optSection' "flood-penalty" "RFC 1459 rate limiting, seconds of penalty per message (default 2)" + $ req ssFloodPenalty valuesSpec + , optSection' "flood-threshold" "RFC 1459 rate limiting, seconds of allowed penalty accumulation (default 10)" + $ req ssFloodThreshold valuesSpec + , optSection' "message-hooks" "Special message hooks to enable: \"buffextras\" available" + $ req ssMessageHooks valuesSpec + , optSection' "reconnect-attempts" "Number of reconnection attempts on lost connection" + $ req ssReconnectAttempts valuesSpec + , optSection' "autoconnect" "Set to `yes` to automatically connect at client startup" + $ req ssAutoconnect yesOrNoSpec + , optSection' "nick-completion" "Behavior for nickname completion with TAB" + $ req ssNickCompletion nickCompletionSpec + , optSection' "log-dir" "Path to log file directory for this server" + $ opt ssLogDir stringSpec + ] -parseNicks :: Value -> ConfigParser (NonEmpty Text) -parseNicks (Text nick) = return (nick NonEmpty.:| []) -parseNicks (List xs) = - do xs' <- parseList parseConfig (List xs) - case xs' of - [] -> failure "empty list" - y:ys -> return (y NonEmpty.:| ys) -parseNicks _ = failure "expected text or list of text" -parseUseTls :: Value -> ConfigParser UseTls -parseUseTls (Atom "yes") = return UseTls -parseUseTls (Atom "yes-insecure") = return UseInsecureTls -parseUseTls (Atom "no") = return UseInsecure -parseUseTls _ = failure "expected yes, yes-insecure, or no" +nicksSpec :: ValueSpecs (NonEmpty Text) +nicksSpec = pure <$> valuesSpec + nonemptyList valuesSpec -parseNum :: Num a => Value -> ConfigParser a -parseNum v = fromInteger <$> parseConfig v -parseIdentifier :: Value -> ConfigParser Identifier -parseIdentifier v = mkId <$> parseConfig v +useTlsSpec :: ValueSpecs UseTls +useTlsSpec = + UseTls <$ atomSpec "yes" + UseInsecureTls <$ atomSpec "yes-insecure" + UseInsecure <$ atomSpec "no" -parseString :: Value -> ConfigParser String -parseString v = Text.unpack <$> parseConfig v +identifierSpec :: ValueSpecs Identifier +identifierSpec = mkId <$> valuesSpec -- | Resolve relative paths starting at the home directory rather than -- the current directory of the client. @@ -340,34 +358,24 @@ | otherwise = do home <- getHomeDirectory return (home path) -parseMacroMap :: Value -> ConfigParser (Recognizer Macro) -parseMacroMap v = fromCommands <$> parseList parseMacro v +macroMapSpec :: ValueSpecs (Recognizer Macro) +macroMapSpec = fromCommands <$> listSpec macroValueSpecs -parseMacro :: Value -> ConfigParser (Text, Macro) -parseMacro = parseSections $ - do name <- sectionReq "name" +macroValueSpecs :: ValueSpecs (Text, Macro) +macroValueSpecs = sectionsSpec "macro" $ + do name <- reqSection "name" "" spec <- fromMaybe noMacroArguments - <$> sectionOptWith parseMacroArguments "arguments" - commands <- sectionReqWith (parseList parseMacroCommand) "commands" + <$> optSection' "arguments" "" macroArgumentsSpec + commands <- reqSection' "commands" "" (listSpec macroCommandSpec) return (name, Macro spec commands) -parseMacroArguments :: Value -> ConfigParser MacroSpec -parseMacroArguments v = - do txt <- parseConfig v - case parseMacroSpecs txt of - Nothing -> failure "bad macro argument specs" - Just ex -> return ex +macroArgumentsSpec :: ValueSpecs MacroSpec +macroArgumentsSpec = customSpec "macro arguments" valuesSpec parseMacroSpecs -parseMacroCommand :: Value -> ConfigParser [ExpansionChunk] -parseMacroCommand v = - do txt <- parseConfig v - case parseExpansion txt of - Nothing -> failure "bad macro line" - Just ex -> return ex +macroCommandSpec :: ValueSpecs [ExpansionChunk] +macroCommandSpec = customSpec "macro command" valuesSpec parseExpansion -parseNickCompletion :: Value -> ConfigParser WordCompletionMode -parseNickCompletion v = - case v of - Atom "default" -> return defaultNickWordCompleteMode - Atom "slack" -> return slackNickWordCompleteMode - _ -> failure "expected default or slack" +nickCompletionSpec :: ValueSpecs WordCompletionMode +nickCompletionSpec = + defaultNickWordCompleteMode <$ atomSpec "default" + slackNickWordCompleteMode <$ atomSpec "slack" diff --git a/src/Client/Configuration/Colors.hs b/src/Client/Configuration/Colors.hs --- a/src/Client/Configuration/Colors.hs +++ b/src/Client/Configuration/Colors.hs @@ -1,4 +1,5 @@ {-# Language OverloadedStrings #-} +{-# Language ApplicativeDo #-} {-| Module : Client.Configuration @@ -11,56 +12,50 @@ -} module Client.Configuration.Colors - ( parseColor - , parseAttr + ( colorSpec + , attrSpec ) where -import Config -import Config.FromConfig +import Config.Schema +import Control.Applicative import Data.HashMap.Strict (HashMap) import qualified Data.HashMap.Strict as HashMap -import Data.Foldable -import Data.Ratio +import Data.Functor.Alt (()) import Data.Text (Text) import Graphics.Vty.Attributes -- | Parse a text attribute. This value should be a sections with the @fg@ and/or -- @bg@ attributes. Otherwise it should be a color entry that will be used -- for the foreground color. An empty sections value will result in 'defAttr' -parseAttr :: Value -> ConfigParser Attr -parseAttr (Sections xs) = parseSectionsWith parseAttrEntry defAttr (Sections xs) -parseAttr v = withForeColor defAttr <$> parseColor v +attrSpec :: ValueSpecs Attr +attrSpec = namedSpec "attr" $ + withForeColor defAttr <$> colorSpec + fullAttrSpec -parseAttrEntry :: Attr -> Text -> Value -> ConfigParser Attr -parseAttrEntry acc k v = - case k of - "fg" -> parseColor' withForeColor - "bg" -> parseColor' withBackColor - "style" -> parseStyle' - _ -> failure "Unknown attribute entry" +fullAttrSpec :: ValueSpecs Attr +fullAttrSpec = sectionsSpec "full-attr" $ + do mbFg <- optSection' "fg" "Foreground color" colorSpec + mbBg <- optSection' "bg" "Background color" colorSpec + mbSt <- optSection' "style" "Terminal font style" stylesSpec + return ( aux withForeColor mbFg + $ aux withBackColor mbBg + $ aux (foldl withStyle) mbSt + $ defAttr) where - parseStyle' = - do xs <- parseStyles v - return $! foldl' withStyle acc xs + aux f xs z = foldl f z xs - parseColor' f = - do c <- parseColor v - return $! f acc c -parseStyles :: Value -> ConfigParser [Style] -parseStyles (List xs) = parseList parseStyle (List xs) -parseStyles v = pure <$> parseStyle v +stylesSpec :: ValueSpecs [Style] +stylesSpec = oneOrList styleSpec -parseStyle :: Value -> ConfigParser Style -parseStyle v = - case v of - Atom "blink" -> pure blink -- You're the boss... - Atom "bold" -> pure bold - Atom "dim" -> pure dim - Atom "reverse-video" -> pure reverseVideo - Atom "standout" -> pure standout - Atom "underline" -> pure underline - _ -> failure "expected blink, bold, dim, reverse-video, standout, underline" +styleSpec :: ValueSpecs Style +styleSpec = namedSpec "style" $ + blink <$ atomSpec "blink" + bold <$ atomSpec "bold" + dim <$ atomSpec "dim" + reverseVideo <$ atomSpec "reverse-video" + standout <$ atomSpec "standout" + underline <$ atomSpec "underline" -- | Parse a color. Support formats are: @@ -68,46 +63,29 @@ -- * Number between 0-255 -- * Name of color -- * RGB values of color as a list -parseColor :: Value -> ConfigParser Color -parseColor v = - case v of - _ | Just i <- parseInteger v -> parseColorNumber i - - Atom a | Just c <- HashMap.lookup (atomName a) namedColors -> return c - - List [r,g,b] - | Just r' <- parseInteger r - , Just g' <- parseInteger g - , Just b' <- parseInteger b -> - parseRgb r' g' b' +colorSpec :: ValueSpecs Color +colorSpec = namedSpec "color" (colorNumberSpec colorNameSpec rgbSpec) - _ -> failure "Expected a color number, name, or RBG list" +colorNameSpec :: ValueSpecs Color +colorNameSpec = customSpec "color name" anyAtomSpec (`HashMap.lookup` namedColors) -- | Match integers between 0 and 255 as Terminal colors. -parseColorNumber :: Integer -> ConfigParser Color -parseColorNumber i - | i < 0 = failure "Negative color not supported" - | i < 16 = return (ISOColor (fromInteger i)) - | i < 256 = return (Color240 (fromInteger (i - 16))) - | otherwise = failure "Color value too high" - --- | Accepts any integer literal or floating literal which can --- be losslessly converted to an integer. -parseInteger :: Value -> Maybe Integer -parseInteger v = - case v of - Number _ i -> Just i - Floating c e - | denominator r == 1 -> Just (numerator r) - where r = fromInteger c * 10^^e - _ -> Nothing +colorNumberSpec :: ValueSpecs Color +colorNumberSpec = customSpec "terminal color" valuesSpec $ \i -> + if i < 0 then Nothing + else if i < 16 then Just (ISOColor (fromInteger i)) + else if i < 256 then Just (Color240 (fromInteger (i - 16))) + else Nothing -parseRgb :: Integer -> Integer -> Integer -> ConfigParser Color -parseRgb r g b - | valid r, valid g, valid b = return (rgbColor r g b) - | otherwise = failure "RGB values must be in range 0-255" +-- | Configuration section that matches 3 integers in the range 0-255 +-- representing red, green, and blue values. +rgbSpec :: ValueSpecs Color +rgbSpec = customSpec "RGB" valuesSpec $ \rgb -> + case rgb of + [r,g,b] | valid r, valid g, valid b -> Just (rgbColor r g b) + _ -> Nothing where - valid x = 0 <= x && x < 256 + valid x = 0 <= x && x < (256 :: Integer) namedColors :: HashMap Text Color namedColors = HashMap.fromList diff --git a/src/Client/Image/Message.hs b/src/Client/Image/Message.hs --- a/src/Client/Image/Message.hs +++ b/src/Client/Image/Message.hs @@ -396,7 +396,7 @@ Just n -> intercalate " " $ map (\(u,i) -> show i ++ [u]) $ dropWhile (\x -> snd x == 0) - $ zip "dhms" [d,h,m,s] + $ zip "dhms" [d,h,m,s :: Int] where (n1,s) = quotRem n 60 (n2,m) = quotRem n1 60 diff --git a/src/Client/Network/Async.hs b/src/Client/Network/Async.hs --- a/src/Client/Network/Async.hs +++ b/src/Client/Network/Async.hs @@ -43,7 +43,6 @@ import Control.Lens import Control.Monad import Data.ByteString (ByteString) -import qualified Data.ByteString as B import Data.Foldable import Data.Time import Irc.RateLimit diff --git a/src/Client/Network/Connect.hs b/src/Client/Network/Connect.hs --- a/src/Client/Network/Connect.hs +++ b/src/Client/Network/Connect.hs @@ -23,8 +23,6 @@ import Control.Applicative import Control.Exception (bracket) import Control.Lens -import Control.Monad -import Data.Monoid ((<>)) import Network.Socket (PortNumber) import Hookup diff --git a/src/Client/Options.hs b/src/Client/Options.hs --- a/src/Client/Options.hs +++ b/src/Client/Options.hs @@ -32,11 +32,13 @@ , getOptions ) where +import Config.Schema.Docs import Control.Lens import Data.Foldable import Data.List import Data.Text (Text) import qualified Data.Text as Text +import qualified Data.Text.IO as Text import Data.Version import Development.GitRev (gitHash, gitDirty) import System.Console.GetOpt @@ -47,6 +49,8 @@ import Paths_glirc (version) import Build_glirc (deps) +import Client.Configuration + -- | Command-line options data Options = Options { _optConfigFile :: Maybe FilePath -- ^ configuration file path @@ -55,6 +59,7 @@ , _optShowHelp :: Bool -- ^ show help message , _optShowVersion :: Bool -- ^ show version message , _optShowFullVersion :: Bool -- ^ show version of ALL transitive dependencies + , _optShowConfigFormat:: Bool -- ^ show configuration file format } makeLenses ''Options @@ -68,6 +73,7 @@ , _optShowVersion = False , _optShowFullVersion = False , _optNoConnect = False + , _optShowConfigFormat= False } -- | Option descriptions @@ -79,6 +85,8 @@ "Disable autoconnecting" , Option "h" ["help"] (NoArg (set optShowHelp True)) "Show help" + , Option "" ["config-format"] (NoArg (set optShowConfigFormat True)) + "Show configuration file format" , Option "v" ["version"] (NoArg (set optShowVersion True)) "Show version" , Option "" ["full-version"] (NoArg (set optShowFullVersion True)) @@ -103,11 +111,12 @@ traverse_ (hPutStr stderr) (map bullet errors) hPutStrLn stderr tryHelpTxt - if | view optShowHelp opts -> putStr helpTxt >> exitSuccess + if | view optShowHelp opts -> putStr helpTxt >> exitSuccess | view optShowFullVersion opts -> putStr fullVersionTxt >> exitSuccess | view optShowVersion opts -> putStr versionTxt >> exitSuccess + | view optShowConfigFormat opts -> Text.putStr (generateDocs configurationSpec) >> exitSuccess | null errors -> return opts - | otherwise -> reportErrors >> exitFailure + | otherwise -> reportErrors >> exitFailure helpTxt :: String helpTxt = usageInfo "glirc2 [FLAGS] INITIAL_NETWORKS..." options diff --git a/src/Config/FromConfig.hs b/src/Config/FromConfig.hs deleted file mode 100644 --- a/src/Config/FromConfig.hs +++ /dev/null @@ -1,208 +0,0 @@ -{-# Language GeneralizedNewtypeDeriving #-} -{-# Language OverloadedStrings #-} - -{-| -Module : Config.FromConfig -Description : Parser for unstructure configuration file format -Copyright : (c) Eric Mertens, 2016 -License : ISC -Maintainer : emertens@gmail.com - -This module provides tools for producing structured configuration -information out of configuration values. - --} -module Config.FromConfig - ( -- * Configuration parsing - ConfigParser - , decodeConfig - , runConfigParser - , failure - , extendLoc - , FromConfig(parseConfig) - - -- * Parser wrappers - , parseList - - -- * Section parsing - , SectionParser - , parseSections - , sectionReq - , sectionReqWith - , sectionOpt - , sectionOptWith - , liftConfigParser - , parseSectionsWith - ) where - -import Config -import Control.Lens hiding (List) -import Control.Monad -import Control.Monad.Trans.Class -import Control.Monad.Trans.Reader -import Control.Monad.Trans.State -import Data.HashMap.Strict (HashMap) -import qualified Data.HashMap.Strict as HashMap -import qualified Data.HashSet as HashSet -import Data.Monoid -import Data.Ratio -import Data.Text (Text) -import qualified Data.Text as Text - --- | Configuration parser tracking current location and for propagating --- error information. -newtype ConfigParser a = ConfigParser (ReaderT [Text] (Either Text) a) - deriving (Functor, Applicative, Monad) - --- | Run a top-level parser to either get the parsed value or an error message. -runConfigParser :: ConfigParser a -> Either Text a -runConfigParser (ConfigParser p) = runReaderT p [] - --- | A parser that always fails with the given error message. -failure :: Text {- ^ error message -} -> ConfigParser a -failure msg = ConfigParser $ - do loc <- ask - let msg' = Text.concat [Text.intercalate "." (reverse loc), ": ", msg] - lift (Left msg') - --- | Embed a parser into an extended location. This is used when --- parsing inside a section. -extendLoc :: Text -> ConfigParser a -> ConfigParser a -extendLoc loc (ConfigParser p) = ConfigParser (local (loc:) p) - ------------------------------------------------------------------------- - --- | Parse a 'Value' according to the method in the 'FromConfig' -decodeConfig :: FromConfig a => Value -> Either Text a -decodeConfig = runConfigParser . parseConfig - --- | Class for types that have a well-known way to parse them. -class FromConfig a where - -- | Parse a value - parseConfig :: Value -> ConfigParser a - --- | Matches 'Text' values. -instance FromConfig Text where - parseConfig (Text x) = return x - parseConfig _ = failure "expected text" - --- | Matches @yes@ as 'True' and @no@ as 'False. -instance FromConfig Bool where - parseConfig (Atom "yes") = return True - parseConfig (Atom "no") = return False - parseConfig _ = failure "expected yes or no" - --- | Matches 'Number' values ignoring the base -instance FromConfig Integer where - parseConfig (Number _ n) = return n - parseConfig (Floating c e) - | denominator n == 1 = return $! numerator n - where - n = floatingToRatio c e - parseConfig _ = failure "expected integral number" - -instance FromConfig Int where - parseConfig v = - do i <- parseConfig v - let small = minBound :: Int - large = maxBound :: Int - when (i < toInteger small || toInteger large < i) - (failure "int out of range") - return (fromInteger i) - --- | Matches 'Number' values ignoring the base -instance Integral a => FromConfig (Ratio a) where - parseConfig (Number _ n) = return $! fromIntegral n - parseConfig (Floating c e) = return $! floatingToRatio c e - parseConfig _ = failure "expected fractional number" - --- | Matches 'Atom' values -instance FromConfig Atom where - parseConfig (Atom a) = return a - parseConfig _ = failure "expected atom" - --- | Matches 'List' values, extends the error location with a zero-based --- index -instance FromConfig a => FromConfig [a] where - parseConfig = parseList parseConfig - ------------------------------------------------------------------------- - --- | Parser for consuming key-value pairs of sections. -newtype SectionParser a = - SectionParser (StateT (HashMap Text Value) ConfigParser a) - deriving (Functor, Applicative, Monad) - --- | Lift a 'ConfigParser' into a 'SectionParser' leaving the current --- section information unmodified. -liftConfigParser :: ConfigParser a -> SectionParser a -liftConfigParser = SectionParser . lift - --- | Run a 'SectionParser' given particular 'Value'. This will only --- succeed when the value is a 'Sections' and the section parser consumes all --- of the sections from that value. -parseSections :: SectionParser a -> Value -> ConfigParser a -parseSections (SectionParser p) (Sections xs) = - do hm <- toHashMap xs - (res, xs') <- runStateT p hm - let unused = HashMap.keys xs' - unless (null unused) - (failure ("unknown keys: " <> Text.intercalate ", " unused)) - return res -parseSections _ _ = failure "expected sections" - --- | --- @ --- sectionOpt = sectionOptWith parseConfig --- @ -sectionOpt :: FromConfig a => Text -> SectionParser (Maybe a) -sectionOpt = sectionOptWith parseConfig - --- | Parses the value stored at the given section with the given parser. --- Nothing is returned if the section is missing. --- Just is returned if the parse succeeds --- Error is raised if the section is present but the parse fails -sectionOptWith :: (Value -> ConfigParser a) -> Text -> SectionParser (Maybe a) -sectionOptWith p key = SectionParser $ - do mb <- at key <<.= Nothing - lift (traverse (extendLoc key . p) mb) - --- | Parse the value at the given section or fail. -sectionReq :: FromConfig a => Text -> SectionParser a -sectionReq = sectionReqWith parseConfig - --- | Parse the value at the given section or fail. -sectionReqWith :: (Value -> ConfigParser a) -> Text -> SectionParser a -sectionReqWith p key = - do mb <- sectionOptWith p key - liftConfigParser $ case mb of - Nothing -> failure ("section required: " <> key) - Just x -> return x - -toHashMap :: [Section] -> ConfigParser (HashMap Text Value) -toHashMap xs = - case duplicateCheck xs of - Just key -> failure ("duplicate section: " <> key) - Nothing -> return $! HashMap.fromList [ (k,v) | Section k v <- xs ] - -duplicateCheck :: [Section] -> Maybe Text -duplicateCheck = go HashSet.empty - where - go _ [] = Nothing - go seen (Section x _:xs) - | HashSet.member x seen = Just x - | otherwise = go (HashSet.insert x seen) xs - -floatingToRatio :: Integral a => Integer -> Integer -> Ratio a -floatingToRatio c e = fromIntegral c * 10 ^^ e - -parseSectionsWith :: (a -> Text -> Value -> ConfigParser a) -> a -> Value -> ConfigParser a -parseSectionsWith p start s = - case s of - Sections xs -> foldM (\x (Section k v) -> extendLoc k (p x k v)) start xs - _ -> failure "Expected sections" - -parseList :: (Value -> ConfigParser a) -> Value -> ConfigParser [a] -parseList p (List xs) = ifor xs $ \i x -> - extendLoc (Text.pack (show (i+1))) (p x) -parseList _ _ = failure "expected list"