glirc 2.29 → 2.30
raw patch · 30 files changed
+767/−231 lines, 30 filesdep ~irc-core
Dependency ranges changed: irc-core
Files
- ChangeLog.md +12/−0
- exec/Main.hs +1/−1
- glirc.cabal +13/−9
- src/Client/Commands.hs +74/−31
- src/Client/Commands/Interpolation.hs +1/−1
- src/Client/Configuration/ServerSettings.hs +7/−1
- src/Client/Configuration/Sts.hs +111/−0
- src/Client/EventLoop.hs +54/−1
- src/Client/Hook/Snotice.hs +67/−0
- src/Client/Hooks.hs +3/−1
- src/Client/Image/Message.hs +20/−13
- src/Client/Image/MircFormatting.hs +42/−23
- src/Client/Image/StatusLine.hs +3/−3
- src/Client/Image/Textbox.hs +31/−29
- src/Client/Message.hs +4/−0
- src/Client/Network/Async.hs +2/−0
- src/Client/Network/Connect.hs +1/−0
- src/Client/State.hs +51/−30
- src/Client/State/EditBox.hs +41/−16
- src/Client/State/EditBox/Content.hs +10/−1
- src/Client/State/Network.hs +90/−37
- src/Client/View/Digraphs.hs +2/−1
- src/Client/View/MaskList.hs +2/−2
- src/Client/View/Mentions.hs +30/−10
- src/Client/View/Messages.hs +2/−1
- src/Client/View/Palette.hs +29/−17
- src/Client/View/UrlSelection.hs +2/−0
- src/Client/View/UserList.hs +2/−3
- src/ContextFilter.hs +40/−0
- src/StrQuote.hs +20/−0
ChangeLog.md view
@@ -1,5 +1,17 @@ # Revision history for glirc2 +## 2.30++* Implement support for chghost <https://ircv3.net/specs/extensions/chghost-3.2.html>+* Implement support for userhost-in-names <https://ircv3.net/specs/extensions/userhost-in-names-3.2.html>+* Implement support for SASL EXTERNAL authentication+* Implement support for CAP 302 <https://ircv3.net/specs/core/capability-negotiation.html>+* Implement support for sts <https://ircv3.net/specs/extensions/sts.html>+* 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
exec/Main.hs view
@@ -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'
glirc.cabal view
@@ -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
src/Client/Commands.hs view
@@ -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) =
src/Client/Commands/Interpolation.hs view
@@ -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
src/Client/Configuration/ServerSettings.hs view
@@ -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" ]
+ src/Client/Configuration/Sts.hs view
@@ -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")
src/Client/EventLoop.hs view
@@ -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 -} ->
+ src/Client/Hook/Snotice.hs view
@@ -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+ []
src/Client/Hooks.hs view
@@ -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) ]
src/Client/Image/Message.hs view
@@ -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
src/Client/Image/MircFormatting.hs view
@@ -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
src/Client/Image/StatusLine.hs view
@@ -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
src/Client/Image/Textbox.hs view
@@ -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)
src/Client/Message.hs view
@@ -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
src/Client/Network/Async.hs view
@@ -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
src/Client/Network/Connect.hs view
@@ -16,6 +16,7 @@ module Client.Network.Connect ( withConnection+ , ircPort ) where import Client.Configuration.ServerSettings
src/Client/State.hs view
@@ -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)
src/Client/State/EditBox.hs view
@@ -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
src/Client/State/EditBox/Content.hs view
@@ -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)
src/Client/State/Network.hs view
@@ -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
src/Client/View/Digraphs.hs view
@@ -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)
src/Client/View/MaskList.hs view
@@ -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)
src/Client/View/Mentions.hs view
@@ -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.
src/Client/View/Messages.hs view
@@ -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
src/Client/View/Palette.hs view
@@ -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<row><col>"+ colorTable++ +++ [ ""+ , "Available terminal palette colors: 0x<row><col>" , "" , 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 =
src/Client/View/UrlSelection.hs view
@@ -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
src/Client/View/UserList.hs view
@@ -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)
+ src/ContextFilter.hs view
@@ -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 _ _ = []
+ src/StrQuote.hs view
@@ -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")+ }