diff --git a/ChangeLog.md b/ChangeLog.md --- a/ChangeLog.md +++ b/ChangeLog.md @@ -1,5 +1,11 @@ # Revision history for glirc2 +## 2.32 + +* Fix SASL EXTERNAL +* Better /url matching +* Support for config-schema improvements + ## 2.31 * Added TLS fingerprint pinning with `tls-cert-fingerprint` and `tls-pubkey-fingerprint` diff --git a/Setup.hs b/Setup.hs --- a/Setup.hs +++ b/Setup.hs @@ -9,16 +9,14 @@ transitive dependencies of this package use free licenses and generates a Build module detailing the versions of build tools and transitive library dependencies. - + -} module Main (main) where import Control.Monad (unless) import Data.Char (isAlphaNum) -import Data.List (delete) import Distribution.InstalledPackageInfo (InstalledPackageInfo, sourcePackageId, license) -import qualified Distribution.ModuleName as ModuleName import Distribution.PackageDescription hiding (license) import Distribution.Simple import Distribution.Simple.LocalBuildInfo (LocalBuildInfo, installedPkgs, withLibLBI) @@ -30,9 +28,7 @@ import Distribution.Simple.BuildPaths (autogenComponentModulesDir) -import qualified Distribution.SPDX as SPDX - -- | Default Setup main extended to generate a Build module and to validate -- the licenses of transitive dependencies. main :: IO () @@ -43,45 +39,9 @@ validateLicenses pkgs generateBuildModule (fromFlag (configVerbosity flags)) pkg lbi pkgs postConf simpleUserHooks args flags pkg lbi - - , sDistHook = \pkg mbLbi hooks flags -> - do let pkg' = forgetBuildModule pkg - sDistHook simpleUserHooks pkg' mbLbi hooks flags } --- | Remove the Build module from the package description. This is needed --- when building a source distribution tarball because the Build module --- should be generated dynamically at configuration time. -forgetBuildModule :: - PackageDescription {- ^ package description with Build module -} -> - PackageDescription {- ^ package description without Build module -} -forgetBuildModule pkg = pkg - { library = forgetInLibrary <$> library pkg - , executables = forgetInExecutable <$> executables pkg - , benchmarks = forgetInBenchmark <$> benchmarks pkg - , testSuites = forgetInTestSuite <$> testSuites pkg - } - where - forget = delete (ModuleName.fromString (buildModuleName pkg)) - - forgetInBuildInfo x = x - { otherModules = forget (otherModules x) } - - forgetInLibrary x = x - { exposedModules = forget (exposedModules x) - , libBuildInfo = forgetInBuildInfo (libBuildInfo x) } - - forgetInTestSuite x = x - { testBuildInfo = forgetInBuildInfo (testBuildInfo x) } - - forgetInBenchmark x = x - { benchmarkBuildInfo = forgetInBuildInfo (benchmarkBuildInfo x) } - - forgetInExecutable x = x - { buildInfo = forgetInBuildInfo (buildInfo x) } - - -- | Compute the name of the Build module for a given package buildModuleName :: PackageDescription {- ^ package description -} -> @@ -137,11 +97,11 @@ IO () validateLicenses pkgs = do let toLicense = either licenseFromSPDX id - p pkg = toLicense (license pkg) `notElem` freeLicenses - badPkgs = filter p pkgs + isBad pkg = toLicense (license pkg) `notElem` freeLicenses + badPkgs = filter isBad pkgs unless (null badPkgs) $ - do mapM_ print [ toLicense (license p) | p <- badPkgs ] + do mapM_ print [ toLicense (license pkg) | pkg <- badPkgs ] fail "BAD LICENSE" diff --git a/glirc.cabal b/glirc.cabal --- a/glirc.cabal +++ b/glirc.cabal @@ -1,6 +1,6 @@ cabal-version: 2.2 name: glirc -version: 2.31 +version: 2.32 synopsis: Console IRC client description: Console IRC client . @@ -19,7 +19,7 @@ exec/macos_exported_symbols.txt homepage: https://github.com/glguy/irc-core bug-reports: https://github.com/glguy/irc-core/issues -tested-with: GHC==8.6.4 +tested-with: GHC==8.6.5 custom-setup setup-depends: base >=4.11 && <4.13, @@ -142,8 +142,8 @@ attoparsec >=0.13 && <0.14, base64-bytestring >=1.0.0.1&& <1.1, bytestring >=0.10.8 && <0.11, - config-schema >=0.4 && <0.6, - config-value >=0.6 && <0.7, + config-schema ^>=1.1.0.0, + config-value ^>=0.6, containers >=0.5.7 && <0.7, directory >=1.2.6 && <1.4, filepath >=1.4.1 && <1.5, @@ -151,7 +151,7 @@ gitrev >=1.2 && <1.4, hashable >=1.2.4 && <1.4, hookup >=0.2.3 && <0.3, - irc-core >=2.7 && <2.8, + irc-core >=2.7.1 && <2.8, kan-extensions >=5.0 && <5.3, lens >=4.14 && <4.18, network >=2.6.2 && <3.2, diff --git a/src/Client/Authentication/Ecdsa.hs b/src/Client/Authentication/Ecdsa.hs --- a/src/Client/Authentication/Ecdsa.hs +++ b/src/Client/Authentication/Ecdsa.hs @@ -21,12 +21,12 @@ ) where import Control.Exception (displayException, try) -import Data.ByteString.Base64 as Enc import Data.Text (Text) import qualified Data.Text as Text import qualified Data.Text.Encoding as Text import System.IO.Error (IOError) import System.Process (readProcess) +import Irc.Commands (AuthenticatePayload(..)) -- | Identifier for SASL ECDSA challenge response authentication @@ -40,8 +40,8 @@ -- | Encode a username as specified in this authentication mode. encodeUsername :: Text {- ^ username -} -> - Text {- ^ base-64 encoded username -} -encodeUsername = Text.decodeUtf8 . Enc.encode . Text.encodeUtf8 + AuthenticatePayload {- ^ base-64 encoded username -} +encodeUsername = AuthenticatePayload . Text.encodeUtf8 -- | Compute the response for a given challenge using the @ecdsatool@ diff --git a/src/Client/Commands/Interpolation.hs b/src/Client/Commands/Interpolation.hs --- a/src/Client/Commands/Interpolation.hs +++ b/src/Client/Commands/Interpolation.hs @@ -65,11 +65,11 @@ noMacroArguments :: MacroSpec noMacroArguments = MacroSpec (pure []) -parseMacroSpecs :: Text -> Maybe MacroSpec +parseMacroSpecs :: Text -> Either Text MacroSpec parseMacroSpecs txt = case parseOnly (macroSpecs <* endOfInput) txt of - Left{} -> Nothing - Right spec -> Just spec + Left e -> Left (Text.pack e) + Right spec -> Right spec macroSpecs :: Parser MacroSpec macroSpecs = @@ -89,11 +89,11 @@ -- | Parse a 'Text' searching for the expansions as specified in -- 'ExpansionChunk'. @$$@ is used to escape a single @$@. -parseExpansion :: Text -> Maybe [ExpansionChunk] +parseExpansion :: Text -> Either Text [ExpansionChunk] parseExpansion txt = case parseOnly (many parseChunk <* endOfInput) txt of - Left{} -> Nothing - Right chunks -> Just chunks + Left e -> Left (Text.pack e) + Right chunks -> Right chunks parseChunk :: Parser ExpansionChunk parseChunk = diff --git a/src/Client/Configuration.hs b/src/Client/Configuration.hs --- a/src/Client/Configuration.hs +++ b/src/Client/Configuration.hs @@ -75,7 +75,7 @@ import Control.Exception import Control.Monad (unless) import Control.Lens hiding (List) -import Data.Foldable (toList, find) +import Data.Foldable (toList) import Data.Functor.Alt (()) import Data.HashMap.Strict (HashMap) import qualified Data.HashMap.Strict as HashMap @@ -241,39 +241,15 @@ Right rawcfg -> return rawcfg case loadValue configurationSpec rawcfg of - Left es -> throwIO - $ ConfigurationMalformed path - $ Text.unpack - $ Text.unlines - $ map explainLoadError (toList es) + Left e -> throwIO + $ ConfigurationMalformed path + $ displayException e Right cfg -> do cfg' <- resolvePaths path (cfg def home) >>= validateDirectories path return (path, cfg') --- | Generate a human-readable explanation of an error arising from --- an attempt to load a configuration file. -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 - - -- | Resolve all the potentially relative file paths in the configuration file resolvePaths :: FilePath -> Configuration -> IO Configuration resolvePaths file cfg = @@ -304,8 +280,8 @@ noWriteableMsg = "The download-dir doesn't point to a writeable directory." configurationSpec :: - ValueSpecs (ServerSettings -> FilePath -> Configuration) -configurationSpec = sectionsSpec "" $ + ValueSpec (ServerSettings -> FilePath -> Configuration) +configurationSpec = sectionsSpec "config-file" $ do let sec' def name spec info = fromMaybe def <$> optSection' name spec info identifierSetSpec = HashSet.fromList <$> listSpec identifierSpec @@ -316,7 +292,7 @@ "Configuration parameters for IRC servers" _configPalette <- sec' defaultPalette "palette" paletteSpec "Customize the client color choices" - _configWindowNames <- sec' defaultWindowNames "window-names" valuesSpec + _configWindowNames <- sec' defaultWindowNames "window-names" anySpec "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`." @@ -330,7 +306,7 @@ "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 + _configIgnores <- sec' [] "ignores" anySpec "Set of nicknames to ignore on startup" _configActivityBar <- sec' False "activity-bar" yesOrNoSpec "Show channel names and message counts for activity on\ @@ -365,7 +341,7 @@ -- > nick-padding: -- > side: right -- > width: 16 -nickPaddingSpec :: ValueSpecs PaddingMode +nickPaddingSpec :: ValueSpec PaddingMode nickPaddingSpec = defaultPaddingSide <$> nonnegativeSpec fullNickPaddingSpec -- | Full nick padding specification: @@ -373,7 +349,7 @@ -- > nick-padding: -- > side: left -- > width: 15 -fullNickPaddingSpec :: ValueSpecs PaddingMode +fullNickPaddingSpec :: ValueSpec PaddingMode fullNickPaddingSpec = sectionsSpec "nick-padding" (sideSec <*> amtSec) where sideSpec = LeftPadding <$ atomSpec "left" @@ -387,7 +363,7 @@ -- | Parse either a single modifier key or a list of modifier keys: -- @meta@, @alt@, @ctrl@ -modifierSpec :: ValueSpecs [Modifier] +modifierSpec :: ValueSpec [Modifier] modifierSpec = toList <$> oneOrNonemptySpec modifier1Spec where modifier1Spec = namedSpec "modifier" @@ -397,13 +373,13 @@ -- | Parse either @one-column@ or @two-column@ and return the corresponding -- 'LayoutMode' value. -layoutSpec :: ValueSpecs LayoutMode +layoutSpec :: ValueSpec LayoutMode layoutSpec = OneColumn <$ atomSpec "one-column" TwoColumn <$ atomSpec "two-column" -- | Parse a single key binding. This can be an action binding, command -- binding, or an unbinding specification. -keyBindingSpec :: ValueSpecs (KeyMap -> KeyMap) +keyBindingSpec :: ValueSpec (KeyMap -> KeyMap) keyBindingSpec = actBindingSpec cmdBindingSpec unbindingSpec -- | Parse a single action key binding. Action bindings are a map specifying @@ -411,7 +387,7 @@ -- -- > bind: "M-a" -- > action: jump-to-activity -actBindingSpec :: ValueSpecs (KeyMap -> KeyMap) +actBindingSpec :: ValueSpec (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)" @@ -419,7 +395,7 @@ "Action name (see `/keymap`)" return (addKeyBinding m k a) -cmdBindingSpec :: ValueSpecs (KeyMap -> KeyMap) +cmdBindingSpec :: ValueSpec (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)" @@ -427,7 +403,7 @@ "Client command to execute (exclude leading `/`)" return (addKeyBinding m k (ActCommand cmd)) -unbindingSpec :: ValueSpecs (KeyMap -> KeyMap) +unbindingSpec :: ValueSpec (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)" @@ -435,34 +411,39 @@ -- | Custom configuration specification for emacs-style key descriptions -keySpec :: ValueSpecs ([Modifier], Key) -keySpec = customSpec "emacs-key" stringSpec parseKey +keySpec :: ValueSpec ([Modifier], Key) +keySpec = customSpec "emacs-key" stringSpec + $ \key -> case parseKey key of + Nothing -> Left "unknown key" + Just x -> Right x -nonnegativeSpec :: (Ord a, Num a) => ValueSpecs a -nonnegativeSpec = customSpec "non-negative" numSpec $ \x -> find (0 <=) [x] +nonnegativeSpec :: (Ord a, Num a) => ValueSpec a +nonnegativeSpec = customSpec "non-negative" numSpec + $ \x -> if x < 0 then Left "negative number" + else Right x -paletteSpec :: ValueSpecs Palette +paletteSpec :: ValueSpec Palette paletteSpec = sectionsSpec "palette" $ (ala Endo (foldMap . foldMap) ?? defaultPalette) <$> sequenceA fields where - nickColorsSpec :: ValueSpecs (Palette -> Palette) + nickColorsSpec :: ValueSpec (Palette -> Palette) nickColorsSpec = set palNicks . Vector.fromList . NonEmpty.toList <$> nonemptySpec attrSpec - modeColorsSpec :: Lens' Palette (HashMap Char Attr) -> ValueSpecs (Palette -> Palette) + modeColorsSpec :: Lens' Palette (HashMap Char Attr) -> ValueSpec (Palette -> Palette) modeColorsSpec l = fmap (set l) $ customSpec "modes" (assocSpec attrSpec) $ fmap HashMap.fromList . traverse (\(mode, attr) -> case Text.unpack mode of - [m] -> Just (m, attr) - _ -> Nothing) + [m] -> Right (m, attr) + _ -> Left "expected single letter") - fields :: [SectionSpecs (Maybe (Palette -> Palette))] + fields :: [SectionsSpec (Maybe (Palette -> Palette))] fields = optSection' "nick-colors" nickColorsSpec "Colors used to highlight nicknames" @@ -477,7 +458,7 @@ : [ optSection' lbl (set l <$> attrSpec) "" | (lbl, Lens l) <- paletteMap ] -extensionSpec :: ValueSpecs ExtensionConfiguration +extensionSpec :: ValueSpec ExtensionConfiguration extensionSpec = simpleExtensionSpec fullExtensionSpec -- | Default dynamic linker flags: @RTLD_LOCAL@ and @RTLD_NOW@ @@ -486,7 +467,7 @@ -- | Given only a filepath build an extension configuration that -- loads the extension using the 'defaultRtldFlags' and no arguments. -simpleExtensionSpec :: ValueSpecs ExtensionConfiguration +simpleExtensionSpec :: ValueSpec ExtensionConfiguration simpleExtensionSpec = do _extensionPath <- stringSpec pure ExtensionConfiguration @@ -497,7 +478,7 @@ -- | Full extension configuration allows the RTLD flags to be manually -- specified. This can be useful if the extension defines symbols that -- need to be visible to libraries that the extension is linked against. -fullExtensionSpec :: ValueSpecs ExtensionConfiguration +fullExtensionSpec :: ValueSpec ExtensionConfiguration fullExtensionSpec = sectionsSpec "extension" $ do _extensionPath <- reqSection' "path" stringSpec @@ -509,7 +490,7 @@ "Extension-specific configuration arguments" pure ExtensionConfiguration {..} -rtldFlagSpec :: ValueSpecs RTLDFlags +rtldFlagSpec :: ValueSpec RTLDFlags rtldFlagSpec = namedSpec "rtld-flag" $ RTLD_LOCAL <$ atomSpec "local" RTLD_GLOBAL <$ atomSpec "global" 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 @@ -26,12 +26,12 @@ -- | 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' -attrSpec :: ValueSpecs Attr +attrSpec :: ValueSpec Attr attrSpec = namedSpec "attr" $ withForeColor defAttr <$> colorSpec fullAttrSpec -fullAttrSpec :: ValueSpecs Attr +fullAttrSpec :: ValueSpec Attr fullAttrSpec = sectionsSpec "full-attr" $ do mbFg <- optSection' "fg" colorSpec "Foreground color" mbBg <- optSection' "bg" colorSpec "Background color" @@ -44,10 +44,10 @@ aux f xs z = foldl f z xs -stylesSpec :: ValueSpecs [Style] +stylesSpec :: ValueSpec [Style] stylesSpec = oneOrList styleSpec -styleSpec :: ValueSpecs Style +styleSpec :: ValueSpec Style styleSpec = namedSpec "style" $ blink <$ atomSpec "blink" bold <$ atomSpec "bold" @@ -62,29 +62,35 @@ -- * Number between 0-255 -- * Name of color -- * RGB values of color as a list -colorSpec :: ValueSpecs Color +colorSpec :: ValueSpec Color colorSpec = namedSpec "color" (colorNumberSpec colorNameSpec rgbSpec) -colorNameSpec :: ValueSpecs Color -colorNameSpec = customSpec "color name" anyAtomSpec (`HashMap.lookup` namedColors) +colorNameSpec :: ValueSpec Color +colorNameSpec = customSpec "color name" anyAtomSpec + $ \name -> case HashMap.lookup name namedColors of + Nothing -> Left "unknown color" + Just c -> Right c -- | Match integers between 0 and 255 as Terminal colors. -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 +colorNumberSpec :: ValueSpec Color +colorNumberSpec = customSpec "terminal color" anySpec $ \i -> + if i < 0 then Left "minimum color is 0" + else if i < 16 then Right (ISOColor (fromInteger i)) + else if i < 256 then Right (Color240 (fromInteger (i - 16))) + else Left "maximum color is 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 -> +rgbSpec :: ValueSpec Color +rgbSpec = customSpec "RGB" anySpec $ \rgb -> case rgb of - [r,g,b] | valid r, valid g, valid b -> Just (rgbColor r g b) - _ -> Nothing + [r,g,b] -> rgbColor <$> valid r <*> valid g <*> valid b + _ -> Left "expected 3 numbers" where - valid x = 0 <= x && x < (256 :: Integer) + valid x + | x < 0 = Left "minimum color value is 0" + | x < 256 = Right (x :: Integer) + | otherwise = Left "maximum color value is 255" namedColors :: HashMap Text Color namedColors = HashMap.fromList diff --git a/src/Client/Configuration/Macros.hs b/src/Client/Configuration/Macros.hs --- a/src/Client/Configuration/Macros.hs +++ b/src/Client/Configuration/Macros.hs @@ -20,19 +20,19 @@ import Data.Maybe (fromMaybe) import Data.Text (Text) -macroMapSpec :: ValueSpecs (Recognizer Macro) -macroMapSpec = fromCommands <$> listSpec macroValueSpecs +macroMapSpec :: ValueSpec (Recognizer Macro) +macroMapSpec = fromCommands <$> listSpec macroValueSpec -macroValueSpecs :: ValueSpecs (Text, Macro) -macroValueSpecs = sectionsSpec "macro" $ +macroValueSpec :: ValueSpec (Text, Macro) +macroValueSpec = sectionsSpec "macro" $ do name <- reqSection "name" "" spec <- fromMaybe noMacroArguments <$> optSection' "arguments" macroArgumentsSpec "" commands <- reqSection' "commands" (oneOrList macroCommandSpec) "" return (name, Macro spec commands) -macroArgumentsSpec :: ValueSpecs MacroSpec -macroArgumentsSpec = customSpec "macro-arguments" valuesSpec parseMacroSpecs +macroArgumentsSpec :: ValueSpec MacroSpec +macroArgumentsSpec = customSpec "macro-arguments" anySpec parseMacroSpecs -macroCommandSpec :: ValueSpecs [ExpansionChunk] -macroCommandSpec = customSpec "macro-command" valuesSpec parseExpansion +macroCommandSpec :: ValueSpec [ExpansionChunk] +macroCommandSpec = customSpec "macro-command" anySpec parseExpansion diff --git a/src/Client/Configuration/ServerSettings.hs b/src/Client/Configuration/ServerSettings.hs --- a/src/Client/Configuration/ServerSettings.hs +++ b/src/Client/Configuration/ServerSettings.hs @@ -75,7 +75,6 @@ import Data.Text (Text) import Data.List.Split (chunksOf, splitOn) import qualified Data.Text as Text -import Data.Word (Word8) import Irc.Identifier (Identifier, mkId) import Network.Socket (HostName, PortNumber, Family(..)) import Numeric (readHex) @@ -175,7 +174,7 @@ , _ssTlsCertFingerprint = Nothing } -serverSpec :: ValueSpecs (ServerSettings -> ServerSettings) +serverSpec :: ValueSpec (ServerSettings -> ServerSettings) serverSpec = sectionsSpec "server-settings" $ composeMaybe <$> sequenceA settings where @@ -192,9 +191,9 @@ $ set l . Just <$> s set l Nothing <$ atomSpec "clear" - settings :: [SectionSpecs (Maybe (ServerSettings -> ServerSettings))] + settings :: [SectionsSpec (Maybe (ServerSettings -> ServerSettings))] settings = - [ opt "name" ssName valuesSpec + [ opt "name" ssName anySpec "The name used to identify this server in the client" , req "hostname" ssHostName stringSpec @@ -206,22 +205,22 @@ , req "nick" ssNicks nicksSpec "Nicknames to connect with in order" - , opt "password" ssPassword valuesSpec + , opt "password" ssPassword anySpec "Server password" - , req "username" ssUser valuesSpec + , req "username" ssUser anySpec "Second component of _!_@_ usermask" - , req "realname" ssReal valuesSpec + , req "realname" ssReal anySpec "\"GECOS\" name sent to server visible in /whois" - , req "userinfo" ssUserInfo valuesSpec + , req "userinfo" ssUserInfo anySpec "CTCP userinfo (currently unused)" - , opt "sasl-username" ssSaslUsername valuesSpec + , opt "sasl-username" ssSaslUsername anySpec "Username for SASL authentication to NickServ" - , opt "sasl-password" ssSaslPassword valuesSpec + , opt "sasl-password" ssSaslPassword anySpec "Password for SASL authentication to NickServ" , opt "sasl-ecdsa-key" ssSaslEcdsaFile stringSpec @@ -254,16 +253,16 @@ , req "chanserv-channels" ssChanservChannels (listSpec identifierSpec) "Channels with ChanServ permissions available" - , req "flood-penalty" ssFloodPenalty valuesSpec + , req "flood-penalty" ssFloodPenalty anySpec "RFC 1459 rate limiting, seconds of penalty per message (default 2)" - , req "flood-threshold" ssFloodThreshold valuesSpec + , req "flood-threshold" ssFloodThreshold anySpec "RFC 1459 rate limiting, seconds of allowed penalty accumulation (default 10)" - , req "message-hooks" ssMessageHooks valuesSpec + , req "message-hooks" ssMessageHooks anySpec "Special message hooks to enable: \"buffextras\" available" - , req "reconnect-attempts" ssReconnectAttempts valuesSpec + , req "reconnect-attempts" ssReconnectAttempts anySpec "Number of reconnection attempts on lost connection" , req "autoconnect" ssAutoconnect yesOrNoSpec @@ -295,22 +294,23 @@ -- 00112233aaFF -- 00:11:22:33:aa:FF -- @ -fingerprintSpec :: ValueSpecs Fingerprint +fingerprintSpec :: ValueSpec Fingerprint fingerprintSpec = customSpec "fingerprint" stringSpec $ \str -> do bytes <- B.pack <$> traverse readWord8 (byteStrs str) case B.length bytes of - 20 -> Just (FingerprintSha1 bytes) - 32 -> Just (FingerprintSha256 bytes) - 64 -> Just (FingerprintSha512 bytes) - _ -> Nothing + 20 -> Right (FingerprintSha1 bytes) + 32 -> Right (FingerprintSha256 bytes) + 64 -> Right (FingerprintSha512 bytes) + _ -> Left "expected 20, 32, or 64 bytes" where -- read a single byte in hex - readWord8 :: String -> Maybe Word8 readWord8 i = case readHex i of - [(x,"")] | 0 <= x, x < 256 -> Just (fromIntegral (x :: Integer)) - _ -> Nothing + [(x,"")] + | 0 <= x, x < 256 -> Right (fromIntegral (x :: Integer)) + | otherwise -> Left "byte out-of-bounds" + _ -> Left "bad hex-encoded byte" byteStrs :: String -> [String] byteStrs str @@ -318,28 +318,28 @@ | otherwise = chunksOf 2 str -- | Specification for IP protocol family. -protocolFamilySpec :: ValueSpecs Family +protocolFamilySpec :: ValueSpec Family protocolFamilySpec = AF_INET <$ atomSpec "inet" AF_INET6 <$ atomSpec "inet6" -nicksSpec :: ValueSpecs (NonEmpty Text) -nicksSpec = oneOrNonemptySpec valuesSpec +nicksSpec :: ValueSpec (NonEmpty Text) +nicksSpec = oneOrNonemptySpec anySpec -useTlsSpec :: ValueSpecs UseTls +useTlsSpec :: ValueSpec UseTls useTlsSpec = UseTls <$ atomSpec "yes" UseInsecureTls <$ atomSpec "yes-insecure" UseInsecure <$ atomSpec "no" -nickCompletionSpec :: ValueSpecs WordCompletionMode +nickCompletionSpec :: ValueSpec WordCompletionMode nickCompletionSpec = defaultNickWordCompleteMode <$ atomSpec "default" slackNickWordCompleteMode <$ atomSpec "slack" -identifierSpec :: ValueSpecs Identifier -identifierSpec = mkId <$> valuesSpec +identifierSpec :: ValueSpec Identifier +identifierSpec = mkId <$> anySpec diff --git a/src/Client/Configuration/Sts.hs b/src/Client/Configuration/Sts.hs --- a/src/Client/Configuration/Sts.hs +++ b/src/Client/Configuration/Sts.hs @@ -45,10 +45,10 @@ makeLenses ''StsPolicy -policySpec :: ValueSpecs StsPolicies +policySpec :: ValueSpec StsPolicies policySpec = HashMap.fromList <$> listSpec policyEntry -policyEntry :: ValueSpecs (Text, StsPolicy) +policyEntry :: ValueSpec (Text, StsPolicy) policyEntry = sectionsSpec "sts-policy" $ do hostname <- reqSection "host" "Hostname" @@ -102,7 +102,7 @@ writeFile path (encodePolicy sts ++ "\n")) :: IO (Either IOError ()) return () -dateTimeSpec :: ValueSpecs UTCTime +dateTimeSpec :: ValueSpec UTCTime dateTimeSpec = customSpec "date-time" stringSpec $ parseTimeM False defaultTimeLocale dateTimeFormat diff --git a/src/Client/EventLoop/Actions.hs b/src/Client/EventLoop/Actions.hs --- a/src/Client/EventLoop/Actions.hs +++ b/src/Client/EventLoop/Actions.hs @@ -100,9 +100,11 @@ , (k,a) <- Map.toList m1 ] -instance Spec Action where - valuesSpec = customSpec "action" anyAtomSpec $ \a -> - fst <$> HashMap.lookup a actionInfos +instance HasSpec Action where + anySpec = customSpec "action" anyAtomSpec + $ \a -> case HashMap.lookup a actionInfos of + Nothing -> Left "unknown action" + Just x -> Right (fst x) -- | Names and default key bindings for each action. diff --git a/src/Client/Hook/Snotice.hs b/src/Client/Hook/Snotice.hs --- a/src/Client/Hook/Snotice.hs +++ b/src/Client/Hook/Snotice.hs @@ -88,12 +88,10 @@ (0, "k", [str|^Propagated ban for |]), -- Chancreate (1, "u", [str|^[^ ]+ is creating new channel #|]), - -- m_filter (0, "u", [str|^FILTER: |]), (0, "m", [str|^New filters loaded.$|]), (0, "m", [str|^Filtering enabled.$|]), - -- Failed login (0, "f", [str|^Warning: [0-9]+ failed login attempts|]), -- Temporary kline added, more complete regex: ^[^ ]+![^ ]+@[^ ]+\{[^ ]+\} added temporary [0-9]+ min. K-Line for \[[^ ]+\] \[.*\]$ @@ -114,7 +112,7 @@ -- PATTERN LIST, uncommon snotes. regex performance isn't very important beyond this point (2, "a", [str|^Possible Flooder|]), - (2, "a", [str|^New Max Local Clients: [0-9]+$|]), + (0, "a", [str|^New Max Local Clients: [0-9]+$|]), (1, "f", [str|^Failed (OPER|CHALLENGE) attempt - host mismatch|]), (3, "f", [str|^Failed (OPER|CHALLENGE) attempt|]), -- ORDER IMPORTANT - catch all failed attempts that aren't host mismatch 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 @@ -71,7 +71,7 @@ = NetworkOpen !ZonedTime [Text] -- | Event for a new recieved line (newline removed) | NetworkLine !ZonedTime !ByteString - -- | Final message indicating the network connection failed + -- | Report an error on network connection network connection failed | NetworkError !ZonedTime !SomeException -- | Final message indicating the network connection finished | NetworkClose !ZonedTime @@ -232,7 +232,7 @@ receiveLoop :: Connection -> TQueue NetworkEvent -> IO () receiveLoop h inQueue = - do mb <- recvLine h (2*ircMaxMessageLength) + do mb <- recvLine h (4*ircMaxMessageLength) for_ mb $ \msg -> do unless (B.null msg) $ -- RFC says to ignore empty messages do now <- getZonedTime diff --git a/src/Client/State.hs b/src/Client/State.hs --- a/src/Client/State.hs +++ b/src/Client/State.hs @@ -678,7 +678,7 @@ compile defaultCompOpt defaultExecOpt{captureGroups=False} - "https?://([[:alnum:]-]+\\.)*([[:alnum:]-]+)(:[[:digit:]]+)?(/[-0-9a-zA-Z$_.+!*'(),%?=:@/;]*)?|\ + "https?://([[:alnum:]-]+\\.)*([[:alnum:]-]+)(:[[:digit:]]+)?(/[-0-9a-zA-Z$_.+!*'(),%?=:@/;~#]*)?|\ \]*>|\ \\\(https?://[^\\)]*\\)" diff --git a/src/Client/State/Network.hs b/src/Client/State/Network.hs --- a/src/Client/State/Network.hs +++ b/src/Client/State/Network.hs @@ -711,7 +711,8 @@ ss = view csSettings cs sasl = ["sasl" | isJust (view ssSaslUsername ss) , isJust (view ssSaslPassword ss) || - isJust (view ssSaslEcdsaFile ss) ] + isJust (view ssSaslEcdsaFile ss) || + isJust (view ssTlsClientCert ss) ] doAuthenticate :: Text -> NetworkState -> ([RawIrcMsg], NetworkState) doAuthenticate param cs = @@ -720,19 +721,19 @@ | "+" <- param , Just user <- view ssSaslUsername ss , Just pass <- view ssSaslPassword ss - -> ([ircAuthenticate (encodePlainAuthentication user pass)], + -> (ircAuthenticates (encodePlainAuthentication user pass), set csAuthenticationState AS_None cs) AS_ExternalStarted | "+" <- param , Just user <- view ssSaslUsername ss - -> ([ircAuthenticate (encodeExternalAuthentication user)], + -> (ircAuthenticates (encodeExternalAuthentication user), set csAuthenticationState AS_None cs) AS_EcdsaStarted | "+" <- param , Just user <- view ssSaslUsername ss - -> ([ircAuthenticate (Ecdsa.encodeUsername user)], + -> (ircAuthenticates (Ecdsa.encodeUsername user), set csAuthenticationState AS_EcdsaWaitChallenge cs) AS_EcdsaWaitChallenge -> ([], cs) -- handled in Client.EventLoop!