diff --git a/ChangeLog.md b/ChangeLog.md --- a/ChangeLog.md +++ b/ChangeLog.md @@ -1,5 +1,17 @@ # Revision history for glirc2 +## 2.30 + +* Implement support for chghost +* Implement support for userhost-in-names +* Implement support for SASL EXTERNAL authentication +* Implement support for CAP 302 +* Implement support for sts +* Add ACCOUNT messages to the metadata lines +* Add logic for server defined user modes +* Ignore leading whitespace when interpreting commands +* Handle more formatting color codes + ## 2.29 * Add support for timers to the extension API * Add `glirc_set_focus` API call diff --git a/exec/Main.hs b/exec/Main.hs --- a/exec/Main.hs +++ b/exec/Main.hs @@ -73,7 +73,7 @@ IO ClientState addInitialNetworks [] st = return st addInitialNetworks (n:ns) st = - do st' <- foldM (flip (addConnection 0 Nothing)) st (n:ns) + do st' <- foldM (\st_ n -> addConnection 0 Nothing Nothing n st_) st (n:ns) return $! set clientFocus (NetworkFocus n) st' -- | Initialize a 'Vty' value and run a continuation. Shutdown the 'Vty' 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.29 +version: 2.30 synopsis: Console IRC client description: Console IRC client . @@ -12,14 +12,14 @@ license-file: LICENSE author: Eric Mertens maintainer: emertens@gmail.com -copyright: 2016,2017 Eric Mertens +copyright: 2016-2019 Eric Mertens category: Network extra-source-files: ChangeLog.md README.md exec/linux_exported_symbols.txt 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.4.3 +tested-with: GHC==8.6.3 custom-setup setup-depends: base >=4.11 && <4.13, @@ -72,10 +72,12 @@ Client.Configuration.Colors Client.Configuration.Macros Client.Configuration.ServerSettings + Client.Configuration.Sts Client.EventLoop Client.EventLoop.Actions Client.EventLoop.Errors Client.Hook + Client.Hook.Snotice Client.Hook.Znc.Buffextras Client.Hooks Client.Image @@ -116,11 +118,13 @@ Client.View.UserList Client.View.Windows - other-modules: LensUtils - StrictUnit - Digraphs + other-modules: ContextFilter DigraphQuote + Digraphs + LensUtils RtsStats + StrQuote + StrictUnit Paths_glirc Build_glirc @@ -142,10 +146,10 @@ gitrev >=1.2 && <1.4, hashable >=1.2.4 && <1.3, hookup >=0.2.2 && <0.3, - irc-core >=2.5 && <2.6, + irc-core >=2.6 && <2.7, kan-extensions >=5.0 && <5.3, lens >=4.14 && <4.18, - network >=2.6.2 && <2.9, + network >=2.6.2 && <3.1, process >=1.4.2 && <1.7, psqueues >=0.2.7 && <0.3, regex-tdfa >=1.2 && <1.3, @@ -159,7 +163,7 @@ unix >=2.7 && <2.8, unordered-containers >=0.2.7 && <0.3, vector >=0.11 && <0.13, - vty >=5.23.1 && <5.25, + vty >=5.23.1 && <5.26, test-suite test type: exitcode-stdio-1.0 diff --git a/src/Client/Commands.hs b/src/Client/Commands.hs --- a/src/Client/Commands.hs +++ b/src/Client/Commands.hs @@ -65,8 +65,6 @@ import LensUtils import RtsStats (getStats) import System.Process -import Text.Regex.TDFA -import Text.Regex.TDFA.String (compile) -- | Possible results of running a command data CommandResult @@ -137,17 +135,18 @@ return $! CommandFailure $! set clientErrorMsg (Just e) st -- | Interpret the given chat message or command. Leading @/@ indicates a --- command. Otherwise if a channel or user query is focused a chat message --- will be sent. +-- command. Otherwise if a channel or user query is focused a chat message will +-- be sent. Leading spaces before the @/@ are ignored when checking for +-- commands. execute :: String {- ^ chat or command -} -> ClientState {- ^ client state -} -> IO CommandResult {- ^ command result -} execute str st = - case str of + case dropWhile (' '==) str of [] -> commandFailure st '/':command -> executeUserCommand Nothing command st - msg -> executeChat msg st + _ -> executeChat str st -- | Execute command provided by user, resolve aliases if necessary. -- @@ -681,27 +680,25 @@ (remainingArg "regular-expression") "Set the persistent regular expression.\n\ \\n\ - \Clear the regular expression by calling this without an argument.\n\ - \\n\ - \\^B/grep\^O is case-sensitive.\n\ - \\^B/grepi\^O is case-insensitive.\n" - $ ClientCommand (cmdGrep True) simpleClientTab - - , Command - (pure "grepi") - (remainingArg "regular-expression") - "Set the persistent regular expression.\n\ + \\^BFlags:\^B\n\ + \ -An Show n messages after match\n\ + \ -Bn Show n messages before match\n\ + \ -Cn Show n messages before and after match\n\ + \ -i Case insensitive match\n\ + \ -- Stop processing flags\n\ \\n\ \Clear the regular expression by calling this without an argument.\n\ \\n\ - \\^B/grep\^O is case-sensitive.\n\ - \\^B/grepi\^O is case-insensitive.\n" - $ ClientCommand (cmdGrep False) simpleClientTab + \\^B/grep\^O is case-sensitive.\n" + $ ClientCommand cmdGrep simpleClientTab , Command (pure "mentions") (pure ()) - "Show a list of all message that were highlighted as important.\n" + "Show a list of all message that were highlighted as important.\n\ + \\n\ + \When using \^B/grep\^B the important messages are those matching\n\ + \the regular expression instead.\n" $ ClientCommand cmdMentions noClientTab ------------------------------------------------------------------------ @@ -1032,7 +1029,9 @@ \When executed in a network window, mode changes are applied to your user.\n\ \When executed in a channel window, mode changes are applied to the channel.\n\ \\n\ - \This command has parameter sensitive tab-completion.\n" + \This command has parameter sensitive tab-completion.\n\ + \\n\ + \See also: /masks\n" $ NetworkCommand cmdMode tabMode , Command @@ -1046,7 +1045,9 @@ \\^BI\^B: invite exemptions (op view only)\n\ \\^Be\^B: ban exemption (op view only)s\n\ \\n\ - \To populate the mask lists for the first time use: /mode \^Bmode\^B\n" + \To populate the mask lists for the first time use: /mode \^Bmode\^B\n\ + \\n\ + \See also: /mode\n" $ ChannelCommand cmdMasks noChannelTab , Command @@ -1139,6 +1140,30 @@ $ NetworkCommand cmdKill simpleNetworkTab , Command + (pure "kline") + (liftA3 (,,) (simpleToken "minutes") (simpleToken "user@host") (remainingArg "reason")) + "Ban a client from the server.\n" + $ NetworkCommand cmdKline simpleNetworkTab + + , Command + (pure "unkline") + (simpleToken "user@host") + "Unban a client from the server.\n" + $ NetworkCommand cmdUnkline simpleNetworkTab + + , Command + (pure "testline") + (simpleToken "[[nick!]user@]host") + "Check matching I/K/D lines for a [[nick!]user@]host\n" + $ NetworkCommand cmdTestline simpleNetworkTab + + , Command + (pure "testmask") + (liftA2 (,) (simpleToken "[nick!]user@host") (optionalArg (simpleToken "gecos"))) + "Test how many local and global clients match a mask.\n" + $ NetworkCommand cmdTestmask simpleNetworkTab + + , Command (pure "map") (pure ()) "Display network map.\n" @@ -1353,7 +1378,7 @@ cmdConnect st networkStr = do -- abort any existing connection before connecting let network = Text.pack networkStr - st' <- addConnection 0 Nothing network =<< abortNetwork network st + st' <- addConnection 0 Nothing Nothing network =<< abortNetwork network st commandSuccess $ changeFocus (NetworkFocus network) st' @@ -1669,6 +1694,26 @@ do sendMsg cs (ircKill (Text.pack client) (Text.pack rest)) commandSuccess st +cmdKline :: NetworkCommand (String, String, String) +cmdKline cs st (minutes, mask, reason) = + do sendMsg cs (ircKline (Text.pack minutes) (Text.pack mask) (Text.pack reason)) + commandSuccess st + +cmdUnkline :: NetworkCommand String +cmdUnkline cs st mask = + do sendMsg cs (ircUnkline (Text.pack mask)) + commandSuccess st + +cmdTestline :: NetworkCommand String +cmdTestline cs st mask = + do sendMsg cs (ircTestline (Text.pack mask)) + commandSuccess st + +cmdTestmask :: NetworkCommand (String, Maybe String) +cmdTestmask cs st (mask, gecos) = + do sendMsg cs (ircTestmask (Text.pack mask) (maybe "" Text.pack gecos)) + commandSuccess st + cmdAway :: NetworkCommand String cmdAway cs st rest = do sendMsg cs (ircAway (Text.pack rest)) @@ -1930,7 +1975,7 @@ | Just network <- views clientFocus focusNetwork st = do tm <- getCurrentTime - st' <- addConnection 0 (Just tm) network =<< abortNetwork network st + st' <- addConnection 0 (Just tm) Nothing network =<< abortNetwork network st commandSuccess $ changeFocus (NetworkFocus network) st' @@ -2300,15 +2345,13 @@ Right{} -> commandSuccess st -- | Implementation of @/grep@ and @/grepi@ -cmdGrep :: - Bool {- ^ case sensitive -} -> - ClientCommand String -cmdGrep sensitive st str +cmdGrep :: ClientCommand String +cmdGrep st str | null str = commandSuccess (set clientRegex Nothing st) | otherwise = - case compile defaultCompOpt{caseSensitive=sensitive} defaultExecOpt str of - Left e -> commandFailureMsg (Text.pack e) st - Right r -> commandSuccess (set clientRegex (Just r) st) + case buildMatcher str of + Nothing -> commandFailureMsg "bad grep" st + Just r -> commandSuccess (set clientRegex (Just r) st) cmdOper :: NetworkCommand (String, String) cmdOper cs st (user, pass) = 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 @@ -108,7 +108,7 @@ parseDefaulted = construct <$> parseVariable - <*> optional (char '|' *> P.takeWhile1 (/= '}')) + <*> optional (char '|' *> P.takeWhile (/= '}')) where construct ch Nothing = ch construct ch (Just l) = DefaultChunk ch l 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 @@ -48,6 +48,7 @@ , ssNickCompletion , ssLogDir , ssProtocolFamily + , ssSts -- * Load function , loadDefaultServerSettings @@ -98,10 +99,11 @@ , _ssMessageHooks :: ![Text] -- ^ Initial message hooks , _ssName :: !(Maybe Text) -- ^ The name referencing the server in commands , _ssReconnectAttempts:: !Int -- ^ The number of reconnect attempts to make on error - , _ssAutoconnect :: Bool -- ^ Connect to this network on server startup + , _ssAutoconnect :: !Bool -- ^ Connect to this network on server startup , _ssNickCompletion :: WordCompletionMode -- ^ Nick completion mode for this server , _ssLogDir :: Maybe FilePath -- ^ Directory to save logs of chat , _ssProtocolFamily :: Maybe Family -- ^ Protocol family to connect with + , _ssSts :: !Bool -- ^ Honor STS policies when true } deriving Show @@ -151,6 +153,7 @@ , _ssNickCompletion = defaultNickWordCompleteMode , _ssLogDir = Nothing , _ssProtocolFamily = Nothing + , _ssSts = True } serverSpec :: ValueSpecs (ServerSettings -> ServerSettings) @@ -255,6 +258,9 @@ , opt "protocol-family" ssProtocolFamily protocolFamilySpec "IP protocol family to use for this connection" + + , req "sts" ssSts yesOrNoSpec + "Honor server STS policies forcing TLS connections" ] diff --git a/src/Client/Configuration/Sts.hs b/src/Client/Configuration/Sts.hs new file mode 100644 --- /dev/null +++ b/src/Client/Configuration/Sts.hs @@ -0,0 +1,111 @@ +{-# LANGUAGE ApplicativeDo, TemplateHaskell, OverloadedStrings #-} + +{-| +Module : Client.Configuration.Sts +Description : STS policy configuration +Copyright : (c) Eric Mertens, 2019 +License : ISC +Maintainer : emertens@gmail.com + +https://ircv3.net/specs/extensions/sts.html + +-} +module Client.Configuration.Sts + ( StsPolicy(..) + , stsExpiration + , stsPort + + , readPolicyFile + , savePolicyFile + ) where + +import Config (Value(..), Section(..), parse, pretty) +import Config.Schema.Spec +import Config.Schema.Load (loadValue) +import Control.Exception (try) +import System.IO.Error (IOError) +import Control.Lens (makeLenses) +import Data.Maybe (fromMaybe) +import Data.Time (UTCTime, defaultTimeLocale, formatTime, parseTimeM, iso8601DateFormat) +import Data.Text (Text) +import qualified Data.Text as Text +import qualified Data.Text.IO as Text +import System.Directory (getXdgDirectory, XdgDirectory(XdgConfig), createDirectoryIfMissing) +import System.FilePath (FilePath, (), takeDirectory) +import Data.HashMap.Strict (HashMap) +import qualified Data.HashMap.Strict as HashMap + +data StsPolicy = StsPolicy + { _stsExpiration :: !UTCTime + , _stsPort :: !Int + } + deriving (Show) + +type StsPolicies = HashMap Text StsPolicy + +makeLenses ''StsPolicy + +policySpec :: ValueSpecs StsPolicies +policySpec = HashMap.fromList <$> listSpec policyEntry + +policyEntry :: ValueSpecs (Text, StsPolicy) +policyEntry = + sectionsSpec "sts-policy" $ + do hostname <- reqSection "host" "Hostname" + expiration <- reqSection' "until" dateTimeSpec "Expiration date" + port <- reqSection "port" "Port number" + return (hostname, StsPolicy expiration port) + +encodePolicy :: StsPolicies -> String +encodePolicy p = + show $ pretty $ + List () + [ Sections () + [ Section () "host" + (Text () k), + Section () "port" + (Number () 10 (fromIntegral (_stsPort v))), + Section () "until" + (Text () + (Text.pack + (formatTime defaultTimeLocale dateTimeFormat + (_stsExpiration v)))) + ] + | (k, v) <- HashMap.toList p ] + +decodePolicy :: Text -> Maybe StsPolicies +decodePolicy txt = + case parse txt of + Left _ -> Nothing + Right rawval -> + case loadValue policySpec rawval of + Left _ -> Nothing + Right policy -> Just policy + +getPolicyFilePath :: IO FilePath +getPolicyFilePath = + do dir <- getXdgDirectory XdgConfig "glirc" + return (dir "sts.cfg") + +readPolicyFile :: IO StsPolicies +readPolicyFile = + do path <- getPolicyFilePath + res <- try (Text.readFile path) :: IO (Either IOError Text) + return $! case res of + Left {} -> HashMap.empty + Right txt -> fromMaybe HashMap.empty (decodePolicy txt) + +savePolicyFile :: StsPolicies -> IO () +savePolicyFile sts = + do path <- getPolicyFilePath + try (do createDirectoryIfMissing True (takeDirectory path) + writeFile path (encodePolicy sts ++ "\n")) :: IO (Either IOError ()) + return () + +dateTimeSpec :: ValueSpecs UTCTime +dateTimeSpec + = customSpec "date-time" stringSpec + $ parseTimeM False defaultTimeLocale dateTimeFormat + +dateTimeFormat :: String +dateTimeFormat = iso8601DateFormat (Just "%H:%M:%S") diff --git a/src/Client/EventLoop.hs b/src/Client/EventLoop.hs --- a/src/Client/EventLoop.hs +++ b/src/Client/EventLoop.hs @@ -22,6 +22,7 @@ import Client.Commands.Interpolation import Client.Configuration (configJumpModifier, configKeyMap, configWindowNames) import Client.Configuration.ServerSettings +import Client.Configuration.Sts import Client.EventLoop.Actions import Client.EventLoop.Errors (exceptionToLines) import Client.Hook @@ -31,6 +32,7 @@ import Client.Log import Client.Message import Client.Network.Async +import Client.Network.Connect (ircPort) import Client.State import qualified Client.State.EditBox as Edit import Client.State.Extensions @@ -49,6 +51,7 @@ import qualified Data.Text as Text import qualified Data.Text.Encoding as Text import qualified Data.Text.Encoding.Error as Text +import qualified Data.Text.Read as Text import Data.Time import GHC.IO.Exception (IOErrorType(..), ioe_type) import Graphics.Vty @@ -207,7 +210,7 @@ | shouldReconnect = do (attempts, mbDisconnectTime) <- computeRetryInfo - addConnection attempts mbDisconnectTime (view csNetwork cs) st + addConnection attempts mbDisconnectTime Nothing (view csNetwork cs) st | otherwise = return st @@ -306,8 +309,58 @@ | AS_EcdsaWaitChallenge <- view csAuthenticationState cs -> processSaslEcdsa now challenge cs st + Cap (CapLs _ caps) + | Just stsVal <- join (lookup "sts" caps) -> processSts stsVal cs st + + Cap (CapNew caps) + | Just stsVal <- join (lookup "sts" caps) -> processSts stsVal cs st + _ -> return st + +processSts :: + Text {- ^ STS parameter string -} -> + NetworkState {- ^ network state -} -> + ClientState {- ^ client state -} -> + IO ClientState +processSts txt cs st = + case view (csSettings . ssTls) cs of + _ | views (csSettings . ssSts) not cs -> return st -- sts disabled + UseInsecure | Just port <- mbPort -> upgradeConnection port + UseTls | Just duration <- mbDuration -> setStsPolicy duration + UseInsecureTls | Just duration <- mbDuration -> setStsPolicy duration + _ -> return st + + where + entries = splitEntry <$> Text.splitOn "," txt + mbPort = readInt =<< lookup "port" entries + mbDuration = readInt =<< lookup "duration" entries + + splitEntry e = + case Text.break ('=' ==) e of + (a, b) -> (a, Text.drop 1 b) + + upgradeConnection port = + do abortConnection StsUpgrade (view csSocket cs) + addConnection 0 (view csLastReceived cs) (Just port) (view csNetwork cs) st + + setStsPolicy duration = + do now <- getCurrentTime + let host = Text.pack (view (csSettings . ssHostName) cs) + port = fromIntegral (ircPort (view csSettings cs)) + policy = StsPolicy + { _stsExpiration = addUTCTime (fromIntegral duration) now + , _stsPort = port } + st' = st & clientStsPolicy . at host ?~ policy + savePolicyFile (view clientStsPolicy st') + return st' + + +readInt :: Text -> Maybe Int +readInt x = + case Text.decimal x of + Right (n, t) | Text.null t -> Just n + _ -> Nothing processSaslEcdsa :: ZonedTime {- ^ message time -} -> diff --git a/src/Client/Hook/Snotice.hs b/src/Client/Hook/Snotice.hs new file mode 100644 --- /dev/null +++ b/src/Client/Hook/Snotice.hs @@ -0,0 +1,67 @@ +{-# Language QuasiQuotes, OverloadedStrings #-} +{-| +Module : Client.Hook.Snotice +Description : Hook for sorting some service notices into separate windows. +Copyright : (c) Eric Mertens 2019 +License : ISC +Maintainer : emertens@gmail.com + +These sorting rules are based on the kinds of messages that freenode's +ircd-seven sends. + +-} +module Client.Hook.Snotice + ( snoticeHook + ) where + +import qualified Data.Text as Text +import Data.Text (Text) +import Data.List (find) +import Text.Regex.TDFA +import Text.Regex.TDFA.String + +import Client.Hook +import Irc.Message +import Irc.Identifier (mkId, Identifier) +import Irc.UserInfo +import Language.Haskell.TH +import StrQuote (str) + +snoticeHook :: MessageHook +snoticeHook = MessageHook "snotice" True remap + +remap :: + IrcMsg -> MessageResult + +remap (Notice (UserInfo u "" "") _ msg) + | Just msg1 <- Text.stripPrefix "*** Notice -- " msg + , let msg2 = Text.filter (\x -> x /= '\x02' && x /= '\x0f') msg1 + , Just (_lvl, cat) <- characterize msg2 + = RemapMessage (Notice (UserInfo u "" "*") cat msg1) + +remap _ = PassMessage + +toPattern :: (Int, String, String) -> (Int, Identifier, Regex) +toPattern (lvl, cat, reStr) = + case compile co eo reStr of + Left e -> error e + Right r -> (lvl, mkId (Text.pack ('~':cat)), r) + where + co = CompOption + { caseSensitive = True + , multiline = False + , rightAssoc = True + , newSyntax = True + , lastStarGreedy = True } + eo = ExecOption + { captureGroups = False } + +characterize :: Text -> Maybe (Int, Identifier) +characterize txt = + do let s = Text.unpack txt + (lvl, cat, _) <- find (\(_, _, re) -> matchTest re s) patterns + pure (lvl, cat) + +patterns :: [(Int, Identifier, Regex)] +patterns = map toPattern + [] diff --git a/src/Client/Hooks.hs b/src/Client/Hooks.hs --- a/src/Client/Hooks.hs +++ b/src/Client/Hooks.hs @@ -19,11 +19,13 @@ import Data.HashMap.Strict import Client.Hook +import Client.Hook.Snotice import Client.Hook.Znc.Buffextras -- | All the available message hooks. messageHooks :: HashMap Text MessageHook messageHooks = fromList - [ ("buffextras", buffextrasHook False) + [ ("snotice", snoticeHook) + , ("buffextras", buffextrasHook False) , ("buffextras-debug", buffextrasHook True) ] 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 @@ -248,7 +248,7 @@ Just ui -> who ui Nothing -> string (view palError pal) "?" - Cap cmd _ -> + Cap cmd -> text' (withForeColor defAttr magenta) (renderCapCmd cmd) <> ":" Mode nick _ _ -> who nick <> " set mode:" @@ -258,6 +258,7 @@ BatchEnd{} -> mempty Account user _ -> who user <> " account:" + Chghost ui _ _ -> who ui <> " chghost:" -- | Render a chat message given a rendering mode, the sigils of the user @@ -296,10 +297,11 @@ text' defAttr (view msgCommand irc) <> char defAttr ' ' <> separatedParams (view msgParams irc) - Cap _ args -> separatedParams args + Cap cmd -> text' defAttr (cleanText (capCmdText cmd)) Mode _ _ params -> ircWords params Account _ acct -> if Text.null acct then "*" else text' defAttr (cleanText acct) + Chghost _ user host -> text' defAttr (cleanText user) <> " " <> text' defAttr (cleanText host) -- | Render a chat message given a rendering mode, the sigils of the user -- who sent the message, and a list of nicknames to highlight. @@ -410,10 +412,10 @@ char defAttr ' ' <> separatedParams (view msgParams irc) - Cap cmd args -> + Cap cmd -> text' (withForeColor defAttr magenta) (renderCapCmd cmd) <> text' defAttr ": " <> - separatedParams args + text' defAttr (cleanText (capCmdText cmd)) Mode nick _chan params -> string quietAttr "mode " <> @@ -429,18 +431,21 @@ who src <> ": " <> if Text.null acct then "*" else text' defAttr (cleanText acct) + Chghost user newuser newhost -> + string quietAttr "chng " <> + who user <> ": " <> + text' defAttr (cleanText newuser) <> " " <> text' defAttr (cleanText newhost) + renderCapCmd :: CapCmd -> Text renderCapCmd cmd = case cmd of - CapLs -> "caps-available" - CapList -> "caps-active" - CapAck -> "caps-acknowledged" - CapNak -> "caps-rejected" - CapEnd -> "caps-finished" -- server shouldn't send this - CapReq -> "caps-requested" -- server shouldn't send this - CapNew -> "caps-offered" - CapDel -> "caps-withdrawn" + CapLs {} -> "caps-available" + CapList {} -> "caps-active" + CapAck {} -> "caps-acknowledged" + CapNak {} -> "caps-rejected" + CapNew {} -> "caps-offered" + CapDel {} -> "caps-withdrawn" separatorImage :: Image' separatorImage = char (withForeColor defAttr blue) 'ยท' @@ -637,7 +642,7 @@ HashSet Identifier {- ^ my nicks -} -> HashSet Identifier {- ^ other nicks -} -> Text -> Image' -highlightNicks palette myNicks nicks txt = mconcat (highlight1 <$> txtParts) +highlightNicks palette myNicks nicks txt = foldMap highlight1 txtParts where txtParts = nickSplit txt allNicks = HashSet.union myNicks nicks @@ -657,6 +662,8 @@ JoinSummary who -> Just (char (withForeColor defAttr green ) '+', who, Nothing) CtcpSummary who -> Just (char (withForeColor defAttr white ) 'C', who, Nothing) NickSummary old new -> Just (char (withForeColor defAttr yellow) '>', old, Just new) + ChngSummary who -> Just (char (withForeColor defAttr blue ) '*', who, Nothing) + AcctSummary who -> Just (char (withForeColor defAttr blue ) '*', who, Nothing) _ -> Nothing -- | Image used when treating ignored chat messages as metadata diff --git a/src/Client/Image/MircFormatting.hs b/src/Client/Image/MircFormatting.hs --- a/src/Client/Image/MircFormatting.hs +++ b/src/Client/Image/MircFormatting.hs @@ -16,6 +16,7 @@ , plainText , controlImage , mircColor + , mircColors ) where import Client.Image.PackedImage as I @@ -27,6 +28,8 @@ import Data.Maybe import Data.Text (Text) import Graphics.Vty.Attributes +import Data.Vector (Vector) +import qualified Data.Vector as Vector makeLensesFor [ ("attrForeColor", "foreColorLens") @@ -77,7 +80,7 @@ mbFmt' = applyControlEffect c fmt next = pIrcLine explicit (fromMaybe fmt mbFmt') -pColorNumbers :: Parser (Maybe (Color, Maybe Color)) +pColorNumbers :: Parser (Maybe (MaybeDefault Color, Maybe (MaybeDefault Color))) pColorNumbers = option Nothing $ do n <- pNumber Just fc <- pure (mircColor n) @@ -95,31 +98,47 @@ optional :: Parser a -> Parser (Maybe a) optional p = option Nothing (Just <$> p) -applyColors :: (Maybe (Color, Maybe Color)) -> Attr -> Attr +applyColors :: Maybe (MaybeDefault Color, Maybe (MaybeDefault Color)) -> Attr -> Attr applyColors Nothing = set foreColorLens Default . set backColorLens Default -applyColors (Just (c1, Nothing)) = set foreColorLens (SetTo c1) -- preserve background -applyColors (Just (c1, Just c2)) = set foreColorLens (SetTo c1) - . set backColorLens (SetTo c2) +applyColors (Just (c1, Nothing)) = set foreColorLens c1 -- preserve background +applyColors (Just (c1, Just c2)) = set foreColorLens c1 + . set backColorLens c2 -mircColor :: Int -> Maybe Color -mircColor 0 = Just (white ) -- white -mircColor 1 = Just (black ) -- black -mircColor 2 = Just (blue ) -- blue -mircColor 3 = Just (green ) -- green -mircColor 4 = Just (red ) -- red -mircColor 5 = Just (rgbColor' 127 0 0 ) -- brown -mircColor 6 = Just (rgbColor' 156 0 156 ) -- purple -mircColor 7 = Just (rgbColor' 252 127 0 ) -- yellow -mircColor 8 = Just (yellow ) -- yellow -mircColor 9 = Just (brightGreen ) -- green -mircColor 10 = Just (cyan ) -- brightBlue -mircColor 11 = Just (brightCyan ) -- brightCyan -mircColor 12 = Just (brightBlue ) -- brightBlue -mircColor 13 = Just (rgbColor' 255 0 255 ) -- brightRed -mircColor 14 = Just (rgbColor' 127 127 127) -- brightBlack -mircColor 15 = Just (rgbColor' 210 210 210) -- brightWhite -mircColor _ = Nothing +mircColor :: Int -> Maybe (MaybeDefault Color) +mircColor 99 = Just Default +mircColor i = SetTo <$> mircColors Vector.!? i + +mircColors :: Vector Color +mircColors = + Vector.fromList $ + [ white -- white + , black -- black + , blue -- blue + , green -- green + , red -- red + , rgbColor' 127 0 0 -- brown + , rgbColor' 156 0 156 -- purple + , rgbColor' 252 127 0 -- yellow + , yellow -- yellow + , brightGreen -- green + , cyan -- brightBlue + , brightCyan -- brightCyan + , brightBlue -- brightBlue + , rgbColor' 255 0 255 -- brightRed + , rgbColor' 127 127 127 -- brightBlack + , rgbColor' 210 210 210 -- brightWhite + ] ++ + map (Color240 . subtract 16) [ -- https://modern.ircdocs.horse/formatting.html#colors-16-98 + 052, 094, 100, 058, + 022, 029, 023, 024, 017, 054, 053, 089, 088, 130, + 142, 064, 028, 035, 030, 025, 018, 091, 090, 125, + 124, 166, 184, 106, 034, 049, 037, 033, 019, 129, + 127, 161, 196, 208, 226, 154, 046, 086, 051, 075, + 021, 171, 201, 198, 203, 215, 227, 191, 083, 122, + 087, 111, 063, 177, 207, 205, 217, 223, 229, 193, + 157, 158, 159, 153, 147, 183, 219, 212, 016, 233, + 235, 237, 239, 241, 244, 247, 250, 254, 231 ] rgbColor' :: Int -> Int -> Int -> Color rgbColor' = rgbColor -- fix the type to Int diff --git a/src/Client/Image/StatusLine.hs b/src/Client/Image/StatusLine.hs --- a/src/Client/Image/StatusLine.hs +++ b/src/Client/Image/StatusLine.hs @@ -106,19 +106,19 @@ | otherwise = infoBubble (string attr "scroll") where pal = clientPalette st - attr = view palLabel pal + attr = view palError pal -- | Indicate when the client is potentially showing a subset of the -- available chat messages. filterImage :: ClientState -> Image' filterImage st = - case clientActiveRegex st of + case clientMatcher st of Nothing -> mempty Just {} -> infoBubble (string attr "filtered") where pal = clientPalette st - attr = view palLabel pal + attr = view palError pal -- | Indicate the current connection health. This will either indicate diff --git a/src/Client/Image/Textbox.hs b/src/Client/Image/Textbox.hs --- a/src/Client/Image/Textbox.hs +++ b/src/Client/Image/Textbox.hs @@ -142,35 +142,37 @@ Bool {- ^ focused -} -> String {- ^ input text -} -> Image' {- ^ output image -} -renderLine st pal myNick nicks macros focused ('/':xs) = - char defAttr '/' <> string attr cleanCmd <> continue rest - where - specAttr spec = - case parse st spec rest of - Nothing -> view palCommand pal - Just{} -> view palCommandReady pal +renderLine st pal myNick nicks macros focused input = - (cmd, rest) = break isSpace xs - cleanCmd = map cleanChar cmd + case span (' '==) input of + (spcs, '/':xs) -> string defAttr spcs <> char defAttr '/' + <> string attr cleanCmd <> continue rest + where + specAttr spec = + case parse st spec rest of + Nothing -> view palCommand pal + Just{} -> view palCommandReady pal - allCommands = (Left <$> macros) <> (Right <$> commands) - (attr, continue) - = case recognize (Text.pack cmd) allCommands of - Exact (Right Command{cmdArgumentSpec = spec}) -> - ( specAttr spec - , render pal st focused spec - ) - Exact (Left (MacroSpec spec)) -> - ( specAttr spec - , render pal st focused spec - ) - Prefix _ -> - ( view palCommandPrefix pal - , parseIrcTextWithNicks pal myNick nicks focused . Text.pack - ) - Invalid -> - ( view palCommandError pal - , parseIrcTextWithNicks pal myNick nicks focused . Text.pack - ) + (cmd, rest) = break (' '==) xs + cleanCmd = map cleanChar cmd -renderLine _ pal myNick nicks _ focused xs = parseIrcTextWithNicks pal myNick nicks focused (Text.pack xs) + allCommands = (Left <$> macros) <> (Right <$> commands) + (attr, continue) + = case recognize (Text.pack cmd) allCommands of + Exact (Right Command{cmdArgumentSpec = spec}) -> + ( specAttr spec + , render pal st focused spec + ) + Exact (Left (MacroSpec spec)) -> + ( specAttr spec + , render pal st focused spec + ) + Prefix _ -> + ( view palCommandPrefix pal + , parseIrcTextWithNicks pal myNick nicks focused . Text.pack + ) + Invalid -> + ( view palCommandError pal + , parseIrcTextWithNicks pal myNick nicks focused . Text.pack + ) + _ -> parseIrcTextWithNicks pal myNick nicks focused (Text.pack input) diff --git a/src/Client/Message.hs b/src/Client/Message.hs --- a/src/Client/Message.hs +++ b/src/Client/Message.hs @@ -63,6 +63,8 @@ | ReplySummary {-# UNPACK #-} !ReplyCode | ChatSummary {-# UNPACK #-} !UserInfo | CtcpSummary {-# UNPACK #-} !Identifier + | ChngSummary {-# UNPACK #-} !Identifier -- ^ Chghost command + | AcctSummary {-# UNPACK #-} !Identifier -- ^ Account command | NoSummary deriving (Eq, Show) @@ -93,4 +95,6 @@ Ctcp who _ _ _ -> CtcpSummary (userNick who) CtcpNotice who _ _ _ -> ChatSummary who Reply code _ -> ReplySummary code + Account who _ -> AcctSummary (userNick who) + Chghost who _ _ -> ChngSummary (userNick who) _ -> NoSummary 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 @@ -80,11 +80,13 @@ data TerminationReason = PingTimeout -- ^ sent when ping timer expires | ForcedDisconnect -- ^ sent when client commands force disconnect + | StsUpgrade -- ^ sent when the client disconnects due to sts policy deriving Show instance Exception TerminationReason where displayException PingTimeout = "connection killed due to ping timeout" displayException ForcedDisconnect = "connection killed by client command" + displayException StsUpgrade = "connection killed by sts policy" -- | Schedule a message to be transmitted on the network connection. -- These messages are sent unmodified. The message should contain a 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 @@ -16,6 +16,7 @@ module Client.Network.Connect ( withConnection + , ircPort ) where import Client.Configuration.ServerSettings diff --git a/src/Client/State.hs b/src/Client/State.hs --- a/src/Client/State.hs +++ b/src/Client/State.hs @@ -45,12 +45,11 @@ , clientLayout , clientRtsStats , clientConfigPath + , clientStsPolicy -- * Client operations , withClientState - , clientMatcher - , clientMatcher' - , clientActiveRegex + , clientMatcher, Matcher(..), buildMatcher , clientToggleHideMeta , clientHighlightsNetwork , channelUserList @@ -109,6 +108,7 @@ import Client.Commands.WordCompletion import Client.Configuration import Client.Configuration.ServerSettings +import Client.Configuration.Sts import Client.Image.Message import Client.Image.Palette import Client.Log @@ -177,7 +177,7 @@ , _clientDetailView :: !Bool -- ^ use detailed rendering mode , _clientActivityBar :: !Bool -- ^ visible activity bar , _clientShowPing :: !Bool -- ^ visible ping time - , _clientRegex :: Maybe Regex -- ^ optional persistent filter + , _clientRegex :: Maybe Matcher -- ^ optional persistent filter , _clientLayout :: !LayoutMode -- ^ layout mode for split screen , _clientBell :: !Bool -- ^ sound a bell next draw @@ -189,8 +189,15 @@ , _clientLogQueue :: ![LogLine] -- ^ log lines ready to write , _clientErrorMsg :: Maybe Text -- ^ transient error box text , _clientRtsStats :: Maybe Stats -- ^ most recent GHC RTS stats + + , _clientStsPolicy :: !(HashMap Text StsPolicy) -- ^ STS policy entries } +data Matcher = Matcher + { matcherBefore :: !Int + , matcherAfter :: !Int + , matcherPred :: LText.Text -> Bool + } -- | State of the extension API including loaded extensions and the mechanism used -- to support reentry into the Haskell runtime from the C API. @@ -235,6 +242,7 @@ withExtensionState $ \exts -> do events <- atomically newTQueue + sts <- readPolicyFile let ignoreIds = map mkId (view configIgnores cfg) k ClientState { _clientWindows = _Empty # () @@ -265,6 +273,7 @@ , _clientLogQueue = [] , _clientErrorMsg = Nothing , _clientRtsStats = Nothing + , _clientStsPolicy = sts } withExtensionState :: (ExtensionState -> IO a) -> IO a @@ -606,41 +615,35 @@ channelUserList network channel = views (clientConnection network . csChannels . ix channel . chanUsers) HashMap.keys - -- | Returns the current filtering predicate if one is active. clientMatcher :: - ClientState {- ^ client state -} -> - Maybe (LText.Text -> Bool) {- ^ optional predicate -} + ClientState {- ^ client state -} -> + Maybe Matcher {- ^ optional predicate -} clientMatcher st = - do r <- clientActiveRegex st - return (matchTest r . LText.unpack) - --- | Strict version of 'clientMatcher' -clientMatcher' :: - ClientState {- ^ client state -} -> - Maybe (Text -> Bool) {- ^ optional predicate -} -clientMatcher' st = - do p <- clientMatcher st - return (p . LText.fromStrict) - - --- | Construct a text matching predicate used to filter the message window. -clientActiveRegex :: ClientState -> Maybe Regex -clientActiveRegex st = case clientActiveCommand st of - Just ("grep" ,reStr) -> go True reStr - Just ("grepi",reStr) -> go False reStr + Just ("grep" , reStr) -> buildMatcher reStr _ -> case view clientRegex st of Nothing -> Nothing Just r -> Just r + +buildMatcher :: String -> Maybe Matcher +buildMatcher = go (True, 0, 0) where - go sensitive reStr = + go (sensitive, b, a) reStr = + case dropWhile (' '==) reStr of + '-' : 'i' : ' ' : reStr' -> go (False, b, a) reStr' + '-' : 'A' : reStr' | [(a' , ' ':reStr'')] <- reads reStr', a' >= 0 -> go (sensitive, b, a') reStr'' + '-' : 'B' : reStr' | [(b' , ' ':reStr'')] <- reads reStr', b' >= 0 -> go (sensitive, b', a) reStr'' + '-' : 'C' : reStr' | [(num, ' ':reStr'')] <- reads reStr', num >= 0 -> go (sensitive, num, num) reStr'' + '-' : '-' : reStr' -> finish (sensitive, b, a) (drop 1 reStr') + _ -> finish (sensitive, b, a) reStr + + finish (sensitive, b, a) reStr = case compile defaultCompOpt{caseSensitive=sensitive} defaultExecOpt{captureGroups=False} reStr of Left{} -> Nothing - Right r -> Just r - + Right r -> Just (Matcher b a (matchTest r . LText.unpack)) -- | Compute the command and arguments currently in the textbox. clientActiveCommand :: @@ -699,10 +702,11 @@ addConnection :: Int {- ^ attempts -} -> Maybe UTCTime {- ^ optional disconnect time -} -> + Maybe Int {- ^ STS upgrade port -} -> Text {- ^ network name -} -> ClientState -> IO ClientState -addConnection attempts lastTime network st = +addConnection attempts lastTime stsUpgrade network st = do let defSettings = (view (clientConfig . configDefaults) st) { _ssName = Just network , _ssHostName = Text.unpack network @@ -711,6 +715,23 @@ settings = fromMaybe defSettings $ preview (clientConfig . configServers . ix network) st + now <- getCurrentTime + let stsUpgrade' + | Just{} <- stsUpgrade = stsUpgrade + | UseInsecure <- view ssTls settings + , let host = Text.pack (view ssHostName settings) + , Just policy <- view (clientStsPolicy . at host) st + , now < view stsExpiration policy + = Just (view stsPort policy) + | otherwise = Nothing + + settings1 = + case stsUpgrade' of + Just port -> set ssPort (Just (fromIntegral port)) + $ set ssTls UseTls settings + Nothing -> settings + + i = nextAvailableKey (view clientConnections st) -- don't bother delaying on the first reconnect @@ -719,10 +740,10 @@ c <- createConnection delay i - settings + settings1 (view clientEvents st) - let cs = newNetworkState i network settings c (PingConnecting attempts lastTime) + let cs = newNetworkState i network settings1 c (PingConnecting attempts lastTime) traverse_ (sendMsg cs) (initialMessages cs) return $ set (clientNetworkMap . at network) (Just i) diff --git a/src/Client/State/EditBox.hs b/src/Client/State/EditBox.hs --- a/src/Client/State/EditBox.hs +++ b/src/Client/State/EditBox.hs @@ -64,11 +64,12 @@ import Client.State.EditBox.Content import Control.Lens hiding (below) import Data.Char +import Data.List.NonEmpty (NonEmpty) data EditBox = EditBox { _content :: !Content - , _history :: ![String] + , _history :: ![NonEmpty String] , _historyPos :: !Int , _yankBuffer :: String , _lastOperation :: !LastOperation @@ -115,7 +116,7 @@ -- the history. success :: EditBox -> EditBox success e - = over history (cons sent) + = over history (cons (pure sent)) $ set content c $ set lastOperation OtherOperation $ set historyPos (-1) @@ -123,30 +124,54 @@ where (sent, c) = shift $ view content e +replaceList :: Int -> [a] -> [a] -> [a] +replaceList i rpl xs = + case splitAt i xs of + (a, b) -> a ++ rpl ++ drop 1 b + -- | Update the editbox to reflect the earlier element in the history. earlier :: EditBox -> Maybe EditBox earlier e = - do let i = view historyPos e + 1 - x <- preview (history . ix i) e - return $ set content (singleLine (endLine x)) + do x <- preview (history . ix (i+1)) e + return $ set content (fromStrings x) $ set lastOperation OtherOperation - $ set historyPos i e + $ set historyPos i' + $ over history updateHistory e + where + i = view historyPos e + i' | i < 0 = length txt + | otherwise = length txt + i + + txt = filter (/= pure "") [toStrings (view content e)] + + updateHistory h + | i < 0 = txt ++ h + | otherwise = replaceList i txt h + -- | Update the editbox to reflect the later element in the history. later :: EditBox -> Maybe EditBox later e - | i < 0 = Nothing - | i == 0 = Just - $ set content noContent - $ set lastOperation OtherOperation - $ set historyPos (-1) e - | otherwise = - do x <- preview (history . ix (i-1)) e - return $ set content (singleLine (endLine x)) + | i < 0 && null txt = Nothing + | otherwise = Just $! + set content newContent $ set lastOperation OtherOperation - $ set historyPos (i-1) e + $ set historyPos i' + $ over history updateHistory e where - i = view historyPos e + txt = filter (/= pure "") [toStrings (view content e)] + + i = view historyPos e + + i' | i < 0 = -1 + | otherwise = i - 1 + + newContent = maybe noContent fromStrings + $ preview (history . ix (i-1)) e + + updateHistory h + | i < 0 = txt ++ h + | otherwise = replaceList i txt h -- | Jump the cursor to the beginning of the input. home :: EditBox -> EditBox diff --git a/src/Client/State/EditBox/Content.hs b/src/Client/State/EditBox/Content.hs --- a/src/Client/State/EditBox/Content.hs +++ b/src/Client/State/EditBox/Content.hs @@ -20,6 +20,8 @@ , singleLine , noContent , shift + , toStrings + , fromStrings -- * Focused line , Line(..) @@ -46,10 +48,11 @@ , digraph ) where -import Control.Lens hiding (below) +import Control.Lens hiding ((<|), below) import Control.Monad (guard) import Data.Char (isAlphaNum) import Data.List (find) +import Data.List.NonEmpty (NonEmpty(..), (<|)) import Digraphs (lookupDigraph) data Line = Line @@ -284,3 +287,9 @@ d <- lookupDigraph x y let line' = Line (n-1) (pfx++d:sfx) Just $! set line line' c + +fromStrings :: NonEmpty String -> Content +fromStrings (x :| xs) = Content xs (endLine x) [] + +toStrings :: Content -> NonEmpty String +toStrings c = foldl (flip (<|)) (view text c :| view above c) (view below c) 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 @@ -114,6 +114,7 @@ , _csChannels :: !(HashMap Identifier ChannelState) -- ^ joined channels , _csSocket :: !NetworkConnection -- ^ network socket , _csModeTypes :: !ModeTypes -- ^ channel mode meanings + , _csUmodeTypes :: !ModeTypes -- ^ user mode meanings , _csChannelTypes :: ![Char] -- ^ channel identifier prefixes , _csTransaction :: !Transaction -- ^ state for multi-message sequences , _csModes :: ![Char] -- ^ modes for the connected user @@ -140,6 +141,7 @@ | AS_PlainStarted -- ^ PLAIN mode initiated | AS_EcdsaStarted -- ^ ECDSA-NIST mode initiated | AS_EcdsaWaitChallenge -- ^ ECDSA-NIST user sent waiting for challenge + | AS_ExternalStarted -- ^ EXTERNAL mode initiated deriving Show -- | Pair of username and hostname. Empty strings represent missing information. @@ -170,6 +172,7 @@ | BanTransaction [(Text,MaskListEntry)] | WhoTransaction [UserInfo] | CapTransaction + | CapLsTransaction [(Text, Maybe Text)] deriving Show makeLenses ''NetworkState @@ -259,6 +262,7 @@ , _csSocket = sock , _csChannelTypes = defaultChannelTypes , _csModeTypes = defaultModeTypes + , _csUmodeTypes = defaultUmodeTypes , _csTransaction = CapTransaction , _csModes = "" , _csStatusMsg = "" @@ -307,6 +311,10 @@ noReply $ recordUser user acct cs + Chghost user newUser newHost -> + noReply + $ updateUserInfo (userNick user) newUser newHost cs + Quit user _reason -> noReply $ forgetUser (userNick user) @@ -336,7 +344,7 @@ in noReply (recordUser (UserInfo (mkId nick) user host) acct' cs) Reply code args -> noReply (doRpl code msgWhen args cs) - Cap cmd params -> doCap cmd params cs + Cap cmd -> doCap cmd cs Authenticate param -> doAuthenticate param cs Mode who target (modes:params) -> doMode msgWhen who target modes params cs Topic user chan topic -> noReply (doTopic msgWhen user chan topic cs) @@ -401,12 +409,13 @@ doRpl cmd msgWhen args = case cmd of RPL_UMODEIS -> + \ns -> case args of _me:modes:params - | Just xs <- splitModes defaultUmodeTypes modes params -> + | Just xs <- splitModes (view csUmodeTypes ns) modes params -> doMyModes xs - . set csModes "" -- reset modes - _ -> id + $ set csModes "" ns -- reset modes + _ -> ns RPL_NOTOPIC -> case args of @@ -442,6 +451,8 @@ overChannel (mkId chan) (set chanUrl (Just urlTxt)) _ -> id + RPL_MYINFO -> myinfo args + RPL_ISUPPORT -> isupport args RPL_NAMREPLY -> @@ -598,7 +609,7 @@ NetworkState -> ([RawIrcMsg], NetworkState) doMode when who target modes args cs | view csNick cs == target - , Just xs <- splitModes defaultUmodeTypes modes args = + , Just xs <- splitModes (view csUmodeTypes cs) modes args = noReply (doMyModes xs cs) | isChannelIdentifier cs target @@ -667,22 +678,25 @@ applyOne modes (False, mode, _) = delete mode modes selectCaps :: - NetworkState {- ^ network state -} -> - [Text] {- ^ server caps -} -> - [Text] {- ^ caps to enable -} -selectCaps cs offered = supported `intersect` offered + NetworkState {- ^ network state -} -> + [(Text, Maybe Text)] {- ^ server caps -} -> + [Text] {- ^ caps to enable -} +selectCaps cs offered = supported `intersect` Map.keys capMap where + capMap = Map.fromList offered + supported = sasl ++ serverTime ++ ["multi-prefix", "batch", "znc.in/playback", "znc.in/self-message" - , "cap-notify", "extended-join", "account-notify" ] + , "cap-notify", "extended-join", "account-notify", "chghost" + , "userhost-in-names", "account-tag" ] -- logic for using IRCv3.2 server-time if available and falling back -- to ZNC's specific extension otherwise. serverTime - | "server-time" `elem` offered = ["server-time"] - | "znc.in/server-time-iso" `elem` offered = ["znc.in/server-time-iso"] - | otherwise = [] + | "server-time" `Map.member` capMap = ["server-time"] + | "znc.in/server-time-iso" `Map.member` capMap = ["znc.in/server-time-iso"] + | otherwise = [] ss = view csSettings cs sasl = ["sasl" | isJust (view ssSaslUsername ss) @@ -693,14 +707,20 @@ doAuthenticate param cs = case view csAuthenticationState cs of AS_PlainStarted - | "+" <- param + | "+" <- param , Just user <- view ssSaslUsername ss , Just pass <- view ssSaslPassword ss -> ([ircAuthenticate (encodePlainAuthentication user pass)], set csAuthenticationState AS_None cs) + AS_ExternalStarted + | "+" <- param + , Just user <- view ssSaslUsername ss + -> ([ircAuthenticate (encodeExternalAuthentication user)], + set csAuthenticationState AS_None cs) + AS_EcdsaStarted - | "+" <- param + | "+" <- param , Just user <- view ssSaslUsername ss -> ([ircAuthenticate (Ecdsa.encodeUsername user)], set csAuthenticationState AS_EcdsaWaitChallenge cs) @@ -713,37 +733,42 @@ ss = view csSettings cs -doCap :: CapCmd -> [Text] -> NetworkState -> ([RawIrcMsg], NetworkState) -doCap cmd args cs = - case (cmd,args) of - (CapLs,[capsTxt]) +doCap :: CapCmd -> NetworkState -> ([RawIrcMsg], NetworkState) +doCap cmd cs = + case cmd of + (CapLs CapMore caps) -> + noReply (set csTransaction (CapLsTransaction (caps ++ prevCaps)) cs) + where + prevCaps = view (csTransaction . _CapLsTransaction) cs + + CapLs CapDone caps | null reqCaps -> endCapTransaction cs - | otherwise -> ([ircCapReq reqCaps], cs) + | otherwise -> ([ircCapReq reqCaps], cs) where - caps = Text.words capsTxt - reqCaps = selectCaps cs caps + reqCaps = selectCaps cs (caps ++ view (csTransaction . _CapLsTransaction) cs) - (CapNew,[capsTxt]) + CapNew caps | null reqCaps -> ([], cs) - | otherwise -> ([ircCapReq reqCaps], cs) + | otherwise -> ([ircCapReq reqCaps], cs) where - caps = Text.words capsTxt reqCaps = selectCaps cs caps - (CapDel,_) -> ([],cs) + CapDel _ -> ([],cs) - (CapAck,[capsTxt]) - | "sasl" `elem` caps -> + CapAck caps + | "sasl" `elem` caps && isJust (view ssSaslUsername ss) -> if isJust (view ssSaslEcdsaFile ss) then ( [ircAuthenticate Ecdsa.authenticationMode] , set csAuthenticationState AS_EcdsaStarted cs) - else if isJust (view ssSaslUsername ss) - then ( [ircAuthenticate plainAuthenticationMode] + else if isJust (view ssSaslPassword ss) + then ( [ircAuthenticate "PLAIN"] , set csAuthenticationState AS_PlainStarted cs) + else if isJust (view ssTlsClientCert ss) + then ( [ircAuthenticate "EXTERNAL"] + , set csAuthenticationState AS_ExternalStarted cs) else endCapTransaction cs where - ss = view csSettings cs - caps = Text.words capsTxt + ss = view csSettings cs _ -> endCapTransaction cs @@ -758,7 +783,7 @@ = [ ircCapLs ] ++ [ ircPass pass | Just pass <- [view ssPassword ss]] ++ [ ircNick (views ssNicks NonEmpty.head ss) - , ircUser (view ssUser ss) False True (view ssReal ss) + , ircUser (view ssUser ss) (view ssReal ss) ] where ss = view csSettings cs @@ -766,20 +791,29 @@ loadNamesList :: Identifier -> NetworkState -> NetworkState loadNamesList chan cs = set csTransaction NoTransaction + $ flip (foldl' (flip learnUserInfo)) (fst <$> entries) $ setStrict (csChannels . ix chan . chanUsers) newChanUsers $ cs where - newChanUsers = HashMap.fromList (splitEntry "" <$> entries) + newChanUsers = HashMap.fromList [ (view uiNick ui, modes) | (ui, modes) <- entries ] + -- userhost-in-names might or might not include the user and host + -- if we find it we update the user information. + learnUserInfo (UserInfo n u h) + | Text.null u || Text.null h = id + | otherwise = updateUserInfo n u h + sigils = toListOf (csModeTypes . modesPrefixModes . folded . _2) cs splitEntry modes str | Text.head str `elem` sigils = splitEntry (Text.head str : modes) (Text.tail str) - | otherwise = (mkId str, reverse modes) + | otherwise = (parseUserInfo str, reverse modes) - entries = - concatMap Text.words (view (csTransaction . _NamesTransaction) cs) + entries :: [(UserInfo, [Char])] + entries = fmap (splitEntry "") + $ concatMap Text.words + $ view (csTransaction . _NamesTransaction) cs createOnJoin :: UserInfo -> Identifier -> NetworkState -> NetworkState @@ -794,6 +828,15 @@ | oldNick == view csNick cs = set csNick newNick cs | otherwise = cs +myinfo :: + [Text] -> + NetworkState -> + NetworkState +myinfo (_me : _host : _version : umodes : _) = + -- special logic for s because I know it has arguments + set (csUmodeTypes . modesNeverArg) (delete 's' (Text.unpack umodes)) +myinfo _ = id + -- ISUPPORT is defined by -- https://tools.ietf.org/html/draft-brocklesby-irc-isupport-03#section-3.14 isupport :: @@ -869,6 +912,16 @@ | Text.null user || Text.null host = id | otherwise = set (csUsers . at nick) (Just $! UserAndHost user host acct) + +-- | Process a CHGHOST command, updating a users information +updateUserInfo :: + Identifier {- ^ nickname -} -> + Text {- ^ new username -} -> + Text {- ^ new hostname -} -> + NetworkState -> NetworkState +updateUserInfo nick user host = + over (csUsers . at nick) $ \old -> + Just $! UserAndHost user host (maybe "" _uhAccount old) forgetUser :: Identifier -> NetworkState -> NetworkState forgetUser = over csUsers . sans diff --git a/src/Client/View/Digraphs.hs b/src/Client/View/Digraphs.hs --- a/src/Client/View/Digraphs.hs +++ b/src/Client/View/Digraphs.hs @@ -17,6 +17,7 @@ import Data.List import Data.List.Split import qualified Data.Text as Text +import qualified Data.Text.Lazy as LText import Data.Text (Text) import Digraphs import Graphics.Vty.Attributes @@ -35,7 +36,7 @@ $ map (Text.pack . drawEntry) $ Text.chunksOf 3 digraphs where - matcher = maybe id filter (clientMatcher' st) + matcher = maybe id (\m -> filter (matcherPred m . LText.fromStrict)) (clientMatcher st) entriesPerLine = max 1 -- just in case? $ (w + sepWidth) `quot` (entryWidth + sepWidth) diff --git a/src/Client/View/MaskList.hs b/src/Client/View/MaskList.hs --- a/src/Client/View/MaskList.hs +++ b/src/Client/View/MaskList.hs @@ -23,8 +23,8 @@ import qualified Data.HashMap.Strict as HashMap import Data.List import Data.Ord -import Data.Maybe import Data.Text (Text) +import qualified Data.Text.Lazy as LText import Data.Time import Graphics.Vty.Attributes import Irc.Identifier @@ -59,7 +59,7 @@ char (view palLabel pal) '/' <> string defAttr (show (HashMap.size entries)) - matcher = fromMaybe (const True) (clientMatcher' st) + matcher = maybe (const True) matcherPred (clientMatcher st) . LText.fromStrict matcher' (mask,entry) = matcher mask || matcher (view maskListSetter entry) diff --git a/src/Client/View/Mentions.hs b/src/Client/View/Mentions.hs --- a/src/Client/View/Mentions.hs +++ b/src/Client/View/Mentions.hs @@ -15,6 +15,7 @@ ) where import Client.Configuration (PaddingMode, configNickPadding) +import Client.Message import Client.Image.Message import Client.Image.PackedImage import Client.Image.Palette (Palette) @@ -25,6 +26,7 @@ import Control.Lens import qualified Data.Map as Map import Data.Time (UTCTime) +import ContextFilter (filterContext) -- | Generate the list of message lines marked important ordered by -- time. Each run of lines from the same channel will be grouped @@ -40,11 +42,17 @@ padAmt = view (clientConfig . configNickPadding) st palette = clientPalette st + filt = + case clientMatcher st of + Nothing -> filter (\x -> WLImportant == view wlImportance x) + Just (Matcher b a p) -> filterContext b a (views wlText p) + entries = merge - [windowEntries palette w padAmt detail n focus v + [windowEntries filt palette w padAmt detail n focus v | (n,(focus, v)) <- names `zip` Map.toList (view clientWindows st) ] + data MentionLine = MentionLine { mlTimestamp :: UTCTime -- ^ message timestamp for sorting , mlWindowName :: Char -- ^ window names shortcut @@ -60,15 +68,17 @@ [Image'] {- ^ mention images and channel labels -} addMarkers _ _ [] = [] addMarkers w !st (!ml : xs) - = concatMap mlImage (ml:same) - ++ minorStatusLineImage (mlFocus ml) w False st - : addMarkers w st rest + = minorStatusLineImage (mlFocus ml) w False st + : concatMap mlImage (ml:same) + ++ addMarkers w st rest where isSame ml' = mlFocus ml == mlFocus ml' (same,rest) = span isSame xs windowEntries :: + ([WindowLine] -> [WindowLine]) + {- ^ filter -} -> Palette {- ^ palette -} -> Int {- ^ draw columns -} -> PaddingMode {- ^ nick padding -} -> @@ -77,18 +87,28 @@ Focus {- ^ window focus -} -> Window {- ^ window -} -> [MentionLine] -windowEntries palette w padAmt detailed name focus win = +windowEntries filt palette w padAmt detailed name focus win = [ MentionLine { mlTimestamp = views wlTimestamp unpackUTCTime l , mlWindowName = name , mlFocus = focus - , mlImage = if detailed - then [view wlFullImage l] - else drawWindowLine palette w padAmt l + , mlImage = case metadataImg (view wlSummary l) of + _ | detailed -> [view wlFullImage l] + Just (img, _, _) -> [img] + Nothing -> drawWindowLine palette w padAmt l } - | let p x = WLImportant == view wlImportance x - , l <- toListOf (winMessages . each . filtered p) win + | l <- filt $ prefilt $ toListOf (winMessages . each) win ] + where + prefilt + | detailed = id + | otherwise = filter isChat + + isChat msg = + case view wlSummary msg of + ChatSummary{} -> True + _ -> False + -- | Merge a list of sorted lists of mention lines into a single sorted list -- in descending order. diff --git a/src/Client/View/Messages.hs b/src/Client/View/Messages.hs --- a/src/Client/View/Messages.hs +++ b/src/Client/View/Messages.hs @@ -31,6 +31,7 @@ import Irc.Identifier import Irc.Message import Irc.UserInfo +import ContextFilter (filterContext) chatMessageImages :: Focus -> Int -> ClientState -> [Image'] @@ -41,7 +42,7 @@ let msgs = toListOf each (view winMessages win) hideMeta = view winHideMeta win in case clientMatcher st of - Just matcher -> windowLineProcessor hideMeta (filter (views wlText matcher) msgs) + Just (Matcher a b p) -> windowLineProcessor hideMeta (filterContext b a (views wlText p) msgs) Nothing -> case view winMarker win of Nothing -> windowLineProcessor hideMeta msgs diff --git a/src/Client/View/Palette.hs b/src/Client/View/Palette.hs --- a/src/Client/View/Palette.hs +++ b/src/Client/View/Palette.hs @@ -20,18 +20,15 @@ import Client.Image.PackedImage import Control.Lens import Data.List +import Data.List.Split (chunksOf) import Graphics.Vty.Attributes +import qualified Data.Vector as Vector digits :: String digits = "0123456789ABCDEF" digitImage :: Char -> Image' -digitImage d = string defAttr [' ',d,' '] - -decimalImage :: Int -> Image' -decimalImage n - | n < 10 = string defAttr (' ':'0':show n) - | otherwise = string defAttr ( ' ':show n) +digitImage d = string defAttr [' ', d, ' '] columns :: [Image'] -> Image' columns = mconcat . intersperse (char defAttr ' ') @@ -60,11 +57,13 @@ , "Chat formatting colors: C-c[foreground[,background]]" , "" - , columns (" " : map decimalImage [0..15]) - , columns mircColors - , "" + ] ++ - , "Available palette colors: 0x" + colorTable + + ++ + [ "" + , "Available terminal palette colors: 0x" , "" , columns (map digitImage (' ':digits)) , columns isoColors ] @@ -80,7 +79,14 @@ | (digit,row) <- zip (drop 1 digits) [0 ..] ] +isLight :: Color -> Bool +isLight (ISOColor c) = c `elem` [1, 3, 5, 6, 7] +isLight (Color240 c) = + case color240CodeToRGB c of + Just (r, g, b) -> (r `max` g `max` b) > 200 + Nothing -> True + isoColors :: [Image'] isoColors = digitImage '0' @@ -88,13 +94,19 @@ | c <- [0..15] ] -mircColors :: [Image'] -mircColors = - " " - : [ string (withBackColor defAttr c) " " - | i <- [0..15] - , let Just c = mircColor i - ] +colorTable :: [Image'] +colorTable + = map (\imgs -> mconcat (" " : imgs)) + $ chunksOf 8 [ render i (mircColors Vector.! i) | i <- [0 .. 15] ] + ++ [[]] + ++ chunksOf 12 [ render i (mircColors Vector.! i) | i <- [16 .. 98] ] + where + showPad i + | i < 10 = '0' : show i + | otherwise = show i + + render i c = + string (withForeColor (withBackColor defAttr c) (if isLight c then black else white)) (' ' : showPad i ++ " ") paletteEntries :: Palette -> [Image'] paletteEntries pal = diff --git a/src/Client/View/UrlSelection.hs b/src/Client/View/UrlSelection.hs --- a/src/Client/View/UrlSelection.hs +++ b/src/Client/View/UrlSelection.hs @@ -78,6 +78,8 @@ NickSummary who _ -> Just who ChatSummary who -> Just (userNick who) CtcpSummary who -> Just who + AcctSummary who -> Just who + ChngSummary who -> Just who ReplySummary {} -> Nothing NoSummary -> Nothing diff --git a/src/Client/View/UserList.hs b/src/Client/View/UserList.hs --- a/src/Client/View/UserList.hs +++ b/src/Client/View/UserList.hs @@ -23,7 +23,6 @@ import qualified Data.HashMap.Strict as HashMap import qualified Data.Map.Strict as Map import Data.List -import Data.Maybe import Data.Ord import Data.Text (Text) import qualified Data.Text as Text @@ -53,7 +52,7 @@ where countImage = drawSigilCount pal (map snd usersList) - matcher = fromMaybe (const True) (clientMatcher st) + matcher = maybe (const True) matcherPred (clientMatcher st) myNicks = clientHighlights cs st @@ -106,7 +105,7 @@ userInfoImages' :: NetworkState -> Identifier -> ClientState -> [Image'] userInfoImages' cs channel st = countImage : map renderEntry usersList where - matcher = fromMaybe (const True) (clientMatcher st) + matcher = maybe (const True) matcherPred (clientMatcher st) countImage = drawSigilCount pal (map snd usersList) diff --git a/src/ContextFilter.hs b/src/ContextFilter.hs new file mode 100644 --- /dev/null +++ b/src/ContextFilter.hs @@ -0,0 +1,40 @@ +module ContextFilter (filterContext) where + +filterContext :: + Int {- ^ context before -} -> + Int {- ^ context after -} -> + (a -> Bool) {- ^ predicate -} -> + [a] {- ^ inputs -} -> + [a] {- ^ matches with context -} +filterContext before after p xs + | before < 0 = error "filterContext: bad before" + | after < 0 = error "filterContext: bad after" + | otherwise = selectList (dropSelection before selects) xs + where + width = before + after + + selects = go 0 xs + + go n [] = replicateKeep n + go n (y : ys) + | p y = Keep (go width ys) + | n > 0 = Keep (go (n - 1) ys) + | otherwise = Skip (go n ys) + +data Selection = End | Keep Selection | Skip Selection + deriving (Show) + +replicateKeep :: Int -> Selection +replicateKeep 0 = End +replicateKeep i = Keep (replicateKeep (i - 1)) + +dropSelection :: Int -> Selection -> Selection +dropSelection 0 x = x +dropSelection _ End = End +dropSelection i (Keep x) = dropSelection (i - 1) x +dropSelection i (Skip x) = dropSelection (i - 1) x + +selectList :: Selection -> [a] -> [a] +selectList (Keep x) (y : ys) = y : selectList x ys +selectList (Skip x) (_ : ys) = selectList x ys +selectList _ _ = [] diff --git a/src/StrQuote.hs b/src/StrQuote.hs new file mode 100644 --- /dev/null +++ b/src/StrQuote.hs @@ -0,0 +1,20 @@ +{-| +Module : StrQuote +Description : Template Haskell quasi-quoter for string literals +Copyright : (c) Eric Mertens, 2017 +License : ISC +Maintainer : emertens@gmail.com + +-} +module StrQuote (str) where + +import Language.Haskell.TH +import Language.Haskell.TH.Quote + +str :: QuasiQuoter +str = QuasiQuoter + { quoteExp = stringE + , quotePat = pure . LitP . StringL + , quoteType = pure . LitT . StrTyLit + , quoteDec = const (fail "str is for expressions") + }