glirc 2.39.0.1 → 2.40

raw patch · 87 files changed

+2341/−1279 lines, 87 filesdep +semigroupoidsdep +typed-processdep +vty-unixdep −processdep ~basedep ~bytestringdep ~config-schemasetup-changed

Dependencies added: semigroupoids, typed-process, vty-unix

Dependencies removed: process

Dependency ranges changed: base, bytestring, config-schema, containers, filepath, free, hookup, irc-core, lens, template-haskell, text, time, unix, vector, vty

Files

ChangeLog.md +12/−0
README.md +2/−2
Setup.hs +4/−2
exec/Exports.hs +2/−0
exec/Main.hs +10/−1
glirc.cabal +33/−23
src/Client/Authentication/Ecdh.hs +2/−2
src/Client/Authentication/Ecdsa.hs +15/−14
src/Client/Authentication/Scram.hs +1/−1
src/Client/CApi.hs +19/−21
src/Client/CApi/Exports.hs +37/−37
src/Client/CApi/Types.hsc +10/−10
src/Client/Commands.hs +39/−44
src/Client/Commands/Arguments/Parser.hs +7/−7
src/Client/Commands/Arguments/Renderer.hs +11/−11
src/Client/Commands/Arguments/Spec.hs +4/−3
src/Client/Commands/Certificate.hs +61/−59
src/Client/Commands/Channel.hs +23/−30
src/Client/Commands/Chat.hs +22/−22
src/Client/Commands/Connection.hs +12/−12
src/Client/Commands/Exec.hs +16/−11
src/Client/Commands/Interpolation.hs +7/−8
src/Client/Commands/Operator.hs +9/−9
src/Client/Commands/Queries.hs +95/−17
src/Client/Commands/Recognizer.hs +5/−7
src/Client/Commands/TabCompletion.hs +11/−11
src/Client/Commands/Toggles.hs +5/−5
src/Client/Commands/Types.hs +16/−7
src/Client/Commands/Window.hs +39/−35
src/Client/Commands/WordCompletion.hs +10/−10
src/Client/Commands/ZNC.hs +10/−11
src/Client/Configuration.hs +53/−52
src/Client/Configuration/Colors.hs +9/−11
src/Client/Configuration/Macros.hs +5/−5
src/Client/Configuration/Notifications.hs +51/−0
src/Client/Configuration/ServerSettings.hs +138/−38
src/Client/Configuration/Sts.hs +18/−20
src/Client/EventLoop.hs +70/−50
src/Client/EventLoop/Actions.hs +14/−14
src/Client/EventLoop/Errors.hs +4/−4
src/Client/EventLoop/Network.hs +22/−22
src/Client/Hook.hs +3/−4
src/Client/Hook/DroneBLRelay.hs +11/−13
src/Client/Hook/Matterbridge.hs +7/−10
src/Client/Hook/Snotice.hs +14/−13
src/Client/Hook/Znc/Buffextras.hs +7/−8
src/Client/Hooks.hs +7/−7
src/Client/Image.hs +5/−6
src/Client/Image/Layout.hs +8/−8
src/Client/Image/LineWrap.hs +4/−4
src/Client/Image/Message.hs +93/−61
src/Client/Image/MircFormatting.hs +14/−14
src/Client/Image/PackedImage.hs +7/−7
src/Client/Image/Palette.hs +90/−42
src/Client/Image/StatusLine.hs +39/−41
src/Client/Image/Textbox.hs +20/−20
src/Client/Log.hs +14/−14
src/Client/Mask.hs +4/−4
src/Client/Message.hs +14/−9
src/Client/Network/Async.hs +24/−24
src/Client/Network/Connect.hs +18/−10
src/Client/Options.hs +16/−17
src/Client/State.hs +141/−74
src/Client/State/Channel.hs +11/−11
src/Client/State/EditBox.hs +6/−6
src/Client/State/EditBox/Content.hs +11/−11
src/Client/State/Extensions.hs +16/−18
src/Client/State/Focus.hs +5/−4
src/Client/State/Network.hs +100/−39
src/Client/State/Url.hs +116/−0
src/Client/State/Window.hs +60/−22
src/Client/UserHost.hs +2/−2
src/Client/View.hs +41/−31
src/Client/View/ChannelList.hs +76/−0
src/Client/View/Mentions.hs +1/−1
src/Client/View/Messages.hs +5/−5
src/Client/View/UrlSelection.hs +12/−22
src/Client/View/Who.hs +88/−0
src/Client/View/Windows.hs +6/−3
src/Client/WhoReply.hs +234/−0
src/ContextFilter.hs +38/−26
src/DigraphQuote.hs +4/−4
src/Digraphs.hs +3/−3
src/LensUtils.hs +3/−3
src/RtsStats.hs +7/−7
src/StrQuote.hs +2/−2
src/StrictUnit.hs +1/−1

ChangeLog.md view

@@ -1,5 +1,17 @@ # Revision history for glirc +* vty-6 support+* deduplicated /url+* locally processed /who+* locally processed /list+* colorized channel identifiers+* better channel and user-mode highlighting. highlights are now per-server so configuration files will need to be updated+* support for 24-bit color output+* OS notification support+* More notification levels for each window+* Better away status handling+* Config file level window hint configuration+ ## 2.39  * Extra oper commands and reply parsing

README.md view

@@ -142,7 +142,7 @@    side: left -- try right if you don't like left padding    width: 13 -url-opener: "open" -- This works on macOS, "gnome-open" for GNOME+url-opener: "open" -- This works on macOS, "xdg-open" for most Linuxes  key-bindings:   * bind: "C-M-b"@@ -178,7 +178,7 @@ | `indent-wrapped-lines` | nonnegative integer | How far to indent lines when they are wrapped                                              | | `extra-highlights`     | list of text        | Extra words/nicks to highlight                                                             | | `extensions`           | list of text        | Filenames of extension to load                                                             |-| `url-opener`           | text                | Command to execute with URL parameter for `/url` e.g. gnome-open on GNOME or open on macOS |+| `url-opener`           | text                | Command to execute with URL parameter for `/url` e.g. xdg-open on most Linuxes or open on macOS | | `ignores`              | list of text        | Initial list of nicknames to ignore                                                        | | `activity-bar`         | yes or no           | Initial setting for visibility of activity bar (default no)                                | | `bell-on-mention`      | yes or no           | Sound terminal bell on transition from not mentioned to mentioned (default no)             |

Setup.hs view

@@ -9,7 +9,7 @@ transitive dependencies of this package use free licenses and generates a Build module detailing the versions of build tools and transitive library dependencies.- + -}  module Main (main) where@@ -98,10 +98,12 @@ validateLicenses pkgs =   do let toLicense = either licenseFromSPDX id          isBad pkg = toLicense (license pkg) `notElem` freeLicenses+                  && pkgName (sourcePackageId pkg) `notElem` exemptions          badPkgs   = filter isBad pkgs+         exemptions = [mkPackageName "system-cxx-std-lib"]       unless (null badPkgs) $-       do mapM_ print [ toLicense (license pkg) | pkg <- badPkgs ]+       do mapM_ print [ (sourcePackageId pkg, toLicense (license pkg)) | pkg <- badPkgs ]           fail "BAD LICENSE"

exec/Exports.hs view

@@ -12,6 +12,8 @@  import Client.CApi.Exports import Client.CApi.Types+import Data.Int+import Data.Word import Foreign.C  foreign export ccall glirc_send_message       :: Glirc_send_message

exec/Main.hs view

@@ -17,6 +17,7 @@ import System.Exit import System.IO import Graphics.Vty+import Graphics.Vty.Platform.Unix (mkVty)  import Client.Configuration import Client.EventLoop@@ -79,4 +80,12 @@ -- | Initialize a 'Vty' value and run a continuation. Shutdown the 'Vty' -- once the continuation finishes. withVty :: (Vty -> IO a) -> IO a-withVty = bracket (mkVty mempty{bracketedPasteMode = Just True}) shutdown+withVty = bracket buildVty shutdown++-- | Generate the initial 'Vty' value and enable the features glirc uses.+buildVty :: IO Vty+buildVty =+ do vty <- mkVty defaultConfig+    setMode (outputIface vty) BracketedPaste True+    setMode (outputIface vty) Focus True+    pure vty

glirc.cabal view

@@ -1,6 +1,6 @@ cabal-version:       2.2 name:                glirc-version:             2.39.0.1+version:             2.40 synopsis:            Console IRC client description:         Console IRC client                      .@@ -14,17 +14,16 @@ maintainer:          emertens@gmail.com copyright:           2016-2019 Eric Mertens category:            Network-extra-source-files:  ChangeLog.md README.md-                     exec/linux_exported_symbols.txt+extra-source-files:  exec/linux_exported_symbols.txt                      exec/macos_exported_symbols.txt-extra-doc-files:     glirc.1+extra-doc-files:     glirc.1 ChangeLog.md README.md homepage:            https://github.com/glguy/irc-core bug-reports:         https://github.com/glguy/irc-core/issues-tested-with:         GHC==8.6.5+tested-with:         GHC==9.4.7  custom-setup-  setup-depends: base     >=4.12 && <4.17,-                 filepath >=1.4  && <1.5,+  setup-depends: base     >=4.12 && <4.20,+                 filepath >=1.4  && <1.6,                  Cabal    >=2.2  && <4  source-repository head@@ -41,7 +40,9 @@   default-language:    Haskell2010    -- Constraints can be found on the library itself-  build-depends:       base, glirc, lens, text, vty+  build-depends:+    base, glirc, lens, text, vty,+    vty-unix             ^>=0.2.0.0,    if os(Linux)     ld-options: -Wl,--dynamic-list=exec/linux_exported_symbols.txt@@ -57,6 +58,9 @@   default-language:    Haskell2010   build-tool-depends:  hsc2hs:hsc2hs +  default-extensions:+    ImportQualifiedPost+   exposed-modules:     Client.Authentication.Ecdsa     Client.Authentication.Ecdh@@ -86,6 +90,7 @@     Client.Configuration     Client.Configuration.Colors     Client.Configuration.Macros+    Client.Configuration.Notifications     Client.Configuration.ServerSettings     Client.Configuration.Sts     Client.EventLoop@@ -120,10 +125,13 @@     Client.State.Extensions     Client.State.Focus     Client.State.Network+    Client.State.Url     Client.State.Window     Client.UserHost+    Client.WhoReply     Client.View     Client.View.Cert+    Client.View.ChannelList     Client.View.ChannelInfo     Client.View.Digraphs     Client.View.Help@@ -136,6 +144,7 @@     Client.View.RtsStats     Client.View.UrlSelection     Client.View.UserList+    Client.View.Who     Client.View.Windows    other-modules:@@ -154,40 +163,41 @@     Build_glirc    build-depends:-    base                 >=4.11   && <4.17,+    base                 >=4.11   && <4.20,     HsOpenSSL            >=0.11   && <0.12,     async                >=2.2    && <2.3,     attoparsec           ^>=0.14,     base64-bytestring    >=1.0.0.1&& <1.3,-    bytestring           >=0.10.8 && <0.12,-    config-schema        ^>=1.2.1.0,+    bytestring           >=0.10.8 && <0.13,+    config-schema        ^>=1.3.0.0,     config-value         ^>=0.8,-    containers           >=0.5.7  && <0.7,+    containers           >=0.5.7  && <0.8,     curve25519           ^>=0.2.5,     directory            >=1.2.6  && <1.4,-    filepath             >=1.4.1  && <1.5,-    free                 >=4.12   && <5.2,+    filepath             >=1.4.1  && <1.6,+    free                 >=4.12   && <5.3,     githash              ^>=0.1.6,     hashable             >=1.2.4  && <1.5,-    hookup               ^>=0.7,+    hookup               ^>=0.8,     irc-core             ^>=2.11,     kan-extensions       >=5.0    && <5.3,-    lens                 >=4.14   && <5.2,+    lens                 >=4.14   && <5.3,     random               >=1.1    && <1.3,     network              >=2.6.2  && <3.2,-    process              >=1.4.2  && <1.7,+    typed-process        ^>=0.2.10,     psqueues             >=0.2.7  && <0.3,     regex-tdfa           >=1.3.1  && <1.4,+    semigroupoids        >=5.1    && <6.1,     split                >=0.2    && <0.3,     stm                  >=2.4    && <2.6,-    template-haskell     >=2.11   && <2.19,-    text                 >=1.2.2  && <2.1,-    time                 >=1.6    && <1.14,+    template-haskell     >=2.11   && <2.22,+    text                 >=1.2.2  && <2.2,+    time                 >=1.10   && <1.14,     transformers         >=0.5.2  && <0.7,-    unix                 >=2.7    && <2.8,+    unix                 >=2.7    && <2.9,     unordered-containers >=0.2.11 && <0.3,-    vector               >=0.11   && <0.13,-    vty                  >=5.35   && <5.36,+    vector               >=0.11   && <0.14,+    vty                  ^>=6.1,  test-suite test   type:                exitcode-stdio-1.0

src/Client/Authentication/Ecdh.hs view

@@ -19,8 +19,8 @@ import Data.Text (Text) import Data.Text.Encoding qualified as Text import Irc.Commands (AuthenticatePayload (AuthenticatePayload))-import OpenSSL.EVP.Digest ( digestBS, getDigestByName, hmacBS, Digest )-import System.IO.Unsafe ( unsafePerformIO )+import OpenSSL.EVP.Digest (digestBS, getDigestByName, hmacBS, Digest)+import System.IO.Unsafe (unsafePerformIO)  newtype Phase1 = Phase1 Curve.PrivateKey

src/Client/Authentication/Ecdsa.hs view

@@ -19,12 +19,13 @@   , computeResponse   ) where -import           Control.Exception (displayException, try)-import           Data.Text (Text)-import qualified Data.Text as Text-import qualified Data.Text.Encoding as Text-import           System.Process (readProcess)-import           Irc.Commands (AuthenticatePayload(..))+import Control.Exception (displayException, try)+import Data.ByteString.Lazy qualified as L+import Data.Text (Text)+import Data.Text qualified as Text+import Data.Text.Encoding qualified as Text+import Irc.Commands (AuthenticatePayload(..))+import System.Process.Typed (readProcessStdout_, proc)   -- | Identifier for SASL ECDSA challenge response authentication@@ -53,11 +54,11 @@   Text                    {- ^ challenge string                 -} ->   IO (Either String Text) {- ^ error message or response string -} computeResponse privateKeyFile challenge =-  do res <- try $ readProcess-                    "ecdsatool"-                    ["sign", privateKeyFile, Text.unpack challenge]-                    "" -- stdin-     return $! case words <$> res of-                 Right [resp] -> Right $! Text.pack resp-                 Right _      -> Left "bad sasl ecdsa response message"-                 Left e       -> Left (displayException (e :: IOError))+  do res <- try (readProcessStdout_ (proc "ecdsatool" ["sign", privateKeyFile, Text.unpack challenge]))+     return $! case res of+                 Left e -> Left (displayException (e :: IOError))+                 Right resp ->+                     case Text.words <$> Text.decodeUtf8' (L.toStrict resp) of+                         Left e      -> Left (displayException e)+                         Right [str] -> Right str+                         Right _     -> Left "bad sasl ecdsa response message"

src/Client/Authentication/Scram.hs view

@@ -25,8 +25,8 @@ import Data.ByteString.Char8 qualified as B8 import Data.List (foldl1') import Data.Text (Text)-import OpenSSL.EVP.Digest ( Digest, digestBS, hmacBS, getDigestByName) import Irc.Commands (AuthenticatePayload (AuthenticatePayload))+import OpenSSL.EVP.Digest (Digest, digestBS, hmacBS, getDigestByName) import System.IO.Unsafe (unsafePerformIO)  data ScramDigest

src/Client/CApi.hs view

@@ -36,27 +36,25 @@   , withRawIrcMsg   ) where -import           Client.Configuration-                   (ExtensionConfiguration,-                    extensionPath, extensionRtldFlags, extensionArgs)-import           Client.CApi.Types-import           Control.Lens (view)-import           Control.Monad-import           Control.Monad.IO.Class-import           Control.Monad.Codensity-import           Data.IntPSQ (IntPSQ)-import qualified Data.IntPSQ as IntPSQ-import           Data.Text (Text)-import qualified Data.Text as Text-import           Data.Time-import           Foreign.C-import           Foreign.Marshal-import           Foreign.Ptr-import           Foreign.Storable-import           Irc.Identifier-import           Irc.RawIrcMsg-import           Irc.UserInfo-import           System.Posix.DynamicLinker+import Client.CApi.Types+import Client.Configuration (ExtensionConfiguration, extensionPath, extensionRtldFlags, extensionArgs)+import Control.Lens (view)+import Control.Monad (guard, unless)+import Control.Monad.Codensity (Codensity(Codensity), lowerCodensity)+import Control.Monad.IO.Class (MonadIO(..))+import Data.IntPSQ (IntPSQ)+import Data.IntPSQ qualified as IntPSQ+import Data.Text (Text)+import Data.Text qualified as Text+import Data.Time (UTCTime)+import Foreign.C (peekCString, withCString)+import Foreign.Marshal (withArray, withArrayLen, with)+import Foreign.Ptr (Ptr, FunPtr, castFunPtrToPtr, nullFunPtr, nullPtr)+import Foreign.Storable (Storable(peek))+import Irc.Identifier (idText)+import Irc.RawIrcMsg (RawIrcMsg(..), TagEntry(..))+import Irc.UserInfo (UserInfo(userHost, userNick, userName))+import System.Posix.DynamicLinker (dlopen, dlclose, dlsym, DL)  ------------------------------------------------------------------------

src/Client/CApi/Exports.hs view

@@ -89,43 +89,43 @@  , glirc_thread  ) where -import           Client.CApi (cancelTimer, pushTimer, ThreadEntry(..), ActiveExtension(aeThreads))-import           Client.CApi.Types-import           Client.Configuration-import           Client.Message-import           Client.State-import           Client.State.Channel-import           Client.State.Focus-import           Client.State.Network-import           Client.State.Window (windowClear, windowSeen, winMessages, wlText)-import           Client.UserHost-import           Control.Concurrent (forkOS)-import           Control.Concurrent.MVar-import           Control.Concurrent.STM (atomically, writeTQueue)-import           Control.Exception-import           Control.Lens-import           Control.Monad (unless)-import           Data.Char (chr)-import           Data.Foldable (traverse_)-import           Data.Functor.Compose-import qualified Data.Map as Map-import           Data.Monoid (First(..))-import qualified Data.HashMap.Strict as HashMap-import           Data.Text (Text)-import qualified Data.Text as Text-import qualified Data.Text.Lazy as LText-import qualified Data.Text.Foreign as Text-import           Data.Time-import           Foreign.C-import           Foreign.Marshal-import           Foreign.Ptr-import           Foreign.StablePtr-import           Foreign.Storable-import           Irc.Identifier-import           Irc.RawIrcMsg-import           Irc.UserInfo-import           Irc.Message-import           LensUtils+import Client.CApi (cancelTimer, pushTimer, ThreadEntry(..), ActiveExtension(aeThreads))+import Client.CApi.Types+import Client.Configuration ( newFilePathContext, resolveFilePath )+import Client.Message+import Client.State+import Client.State.Channel ( chanLists, chanModes, chanUsers )+import Client.State.Focus (Focus(ChannelFocus, Unfocused, NetworkFocus))+import Client.State.Network (csChannels, csNick, csUsers, isChannelIdentifier, sendMsg)+import Client.State.Window (windowClear, windowSeen, winMessages, wlText)+import Client.UserHost (uhAccount)+import Control.Concurrent (forkOS)+import Control.Concurrent.MVar (MVar, modifyMVar, modifyMVar_, readMVar)+import Control.Concurrent.STM (atomically, writeTQueue)+import Control.Exception (SomeException(SomeException), catch)+import Control.Lens+import Control.Monad (unless)+import Data.Char (chr)+import Data.Foldable (traverse_)+import Data.Functor.Compose ( Compose(Compose) )+import Data.HashMap.Strict qualified as HashMap+import Data.Map qualified as Map+import Data.Monoid (First(..))+import Data.Text (Text)+import Data.Text qualified as Text+import Data.Text.Foreign qualified as Text+import Data.Text.Lazy qualified as LText+import Data.Time (addUTCTime, getCurrentTime, getZonedTime)+import Foreign.C (CString, CInt, CChar, CSize, newCString, CULong)+import Foreign.Marshal (newArray0, peekArray, peekArray0, free)+import Foreign.Ptr (Ptr, FunPtr, nullPtr)+import Foreign.StablePtr (castPtrToStablePtr, deRefStablePtr)+import Foreign.Storable (Storable(peek))+import Irc.Identifier (idText, mkId)+import Irc.Message (IrcMsg(Privmsg), Source(Source))+import Irc.RawIrcMsg (RawIrcMsg(..), TagEntry(TagEntry))+import Irc.UserInfo (UserInfo(UserInfo), parseUserInfo)+import LensUtils (overStrict)  ------------------------------------------------------------------------

src/Client/CApi/Types.hsc view

@@ -1,4 +1,4 @@-{-# Language RecordWildCards #-}+{-# Language RecordWildCards, ImportQualifiedPost #-}  {-| Module      : Client.CApi.Types@@ -60,15 +60,15 @@   , poke'   ) where -import           Control.Monad-import           Data.Text (Text)-import qualified Data.Text.Foreign as Text-import           Data.Word-import           Data.Int-import           Foreign.C-import           Foreign.Marshal.Array-import           Foreign.Ptr-import           Foreign.Storable+import Control.Monad+import Data.Int+import Data.Text (Text)+import Data.Text.Foreign qualified as Text+import Data.Word+import Foreign.C+import Foreign.Marshal.Array+import Foreign.Ptr+import Foreign.Storable  -- | Tag for describing the kind of message to display in the client -- as used in `glirc_print`. See 'normalMessage' and 'errorMessage'.

src/Client/Commands.hs view

@@ -25,44 +25,44 @@   , commandsList   ) where -import           Client.Commands.Arguments.Spec-import           Client.Commands.Arguments.Parser-import           Client.Commands.Exec-import           Client.Commands.Interpolation-import           Client.Commands.Recognizer-import           Client.Commands.WordCompletion-import           Client.Configuration-import           Client.State-import           Client.State.Extensions-import           Client.State.Focus-import           Client.State.Network-import           Client.State.Window-import           Control.Applicative-import           Control.Exception (displayException, try)-import           Control.Lens-import           Control.Monad-import           Data.Foldable-import           Data.Text (Text)-import qualified Data.Text as Text-import           Data.Time (getZonedTime)-import           Irc.Commands-import           Irc.Identifier-import           Irc.RawIrcMsg-import           Irc.Message-import           RtsStats (getStats)-import           System.Process+import Client.Commands.Arguments.Parser (parse)+import Client.Commands.Arguments.Spec (optionalArg, optionalNumberArg, remainingArg, simpleToken)+import Client.Commands.Exec+import Client.Commands.Interpolation (resolveMacroExpansions, Macro(Macro), MacroSpec(MacroSpec))+import Client.Commands.Recognizer (fromCommands, keys, recognize, Recognition(Exact), Recognizer)+import Client.Commands.WordCompletion (caseText, plainWordCompleteMode, wordComplete)+import Client.Configuration+import Client.State+import Client.State.Extensions (clientCommandExtension, clientStartExtensions)+import Client.State.Focus+import Client.State.Network (csNick, isChannelIdentifier, sendMsg)+import Client.State.Url+import Control.Applicative (liftA2, (<|>))+import Control.Exception (displayException, try)+import Control.Lens+import Control.Monad (guard, foldM)+import Data.Foldable (foldl', toList)+import Data.Text (Text)+import Data.Text qualified as Text+import Data.Time (getZonedTime)+import Irc.Commands (ircPrivmsg)+import Irc.Identifier (idText)+import Irc.Message (IrcMsg(Privmsg))+import Irc.RawIrcMsg (parseRawIrcMsg)+import RtsStats (getStats)+import System.Process.Typed (proc, runProcess_) -import           Client.Commands.Channel (channelCommands)-import           Client.Commands.Certificate (newCertificateCommand)-import           Client.Commands.Chat (chatCommands, chatCommand', executeChat)-import           Client.Commands.Connection (connectionCommands)-import           Client.Commands.Operator (operatorCommands)-import           Client.Commands.Queries (queryCommands)-import           Client.Commands.Toggles (togglesCommands)-import           Client.Commands.Window (windowCommands)-import           Client.Commands.ZNC (zncCommands)-import           Client.Commands.TabCompletion-import           Client.Commands.Types+import Client.Commands.Certificate (newCertificateCommand)+import Client.Commands.Channel (channelCommands)+import Client.Commands.Chat (chatCommands, chatCommand', executeChat)+import Client.Commands.Connection (connectionCommands)+import Client.Commands.Operator (operatorCommands)+import Client.Commands.Queries (queryCommands)+import Client.Commands.TabCompletion+import Client.Commands.Toggles (togglesCommands)+import Client.Commands.Types+import Client.Commands.Window (windowCommands)+import Client.Commands.ZNC (zncCommands)  -- | Interpret the given chat message or command. Leading @/@ indicates a -- command. Otherwise if a channel or user query is focused a chat message will@@ -507,13 +507,8 @@     Nothing     -> commandFailureMsg "url-opener not configured" st     Just opener -> doUrlOpen opener (maybe 0 (subtract 1) arg)   where-    focus = view clientFocus st--    urls = toListOf ( clientWindows . ix focus . winMessages . each . wlText-                    . folding urlMatches) st-     doUrlOpen opener n =-      case preview (ix n) urls of+      case preview (ix n) (map fst (urlList st)) of         Just url -> openUrl opener (Text.unpack url) st         Nothing  -> commandFailureMsg "bad url number" st @@ -521,7 +516,7 @@ openUrl (UrlOpener opener args) url st =   do let argStr (UrlArgLiteral str) = str          argStr UrlArgUrl           = url-     res <- try (callProcess opener (map argStr args))+     res <- try (runProcess_ (proc opener (map argStr args)))      case res of        Left e  -> commandFailureMsg (Text.pack (displayException (e :: IOError))) st        Right{} -> commandSuccess st

src/Client/Commands/Arguments/Parser.hs view

@@ -11,12 +11,12 @@  module Client.Commands.Arguments.Parser (parse) where -import Client.Commands.Arguments.Spec-import Control.Applicative-import Control.Monad-import Control.Monad.Trans.State-import Control.Monad.Trans.Class-import Control.Applicative.Free+import Client.Commands.Arguments.Spec (Arg(..), Args, ArgumentShape(..))+import Control.Applicative (optional)+import Control.Applicative.Free (runAp)+import Control.Monad (guard)+import Control.Monad.Trans.Class (MonadTrans(lift))+import Control.Monad.Trans.State (StateT(runStateT), get, put)  ------------------------------------------------------------------------ -- Parser@@ -30,7 +30,7 @@ type Parser = StateT String Maybe  parseArgs :: r -> Args r a -> Parser a-parseArgs env spec = runAp (parseArg env) spec+parseArgs env = runAp (parseArg env)  parseArg :: r -> Arg r a -> Parser a parseArg env spec =

src/Client/Commands/Arguments/Renderer.hs view

@@ -11,17 +11,17 @@  module Client.Commands.Arguments.Renderer (render) where -import           Client.Commands.Arguments.Spec-import           Client.Image.MircFormatting-import           Client.Image.PackedImage-import           Client.Image.Palette-import           Control.Applicative.Free-import           Control.Lens-import           Control.Monad.Trans.State-import           Data.Functor.Compose-import qualified Data.Text as Text-import           Graphics.Vty (wcswidth)-import           Graphics.Vty.Attributes+import Client.Commands.Arguments.Spec (Arg(..), Args, ArgumentShape(RemainingArgument, TokenArgument))+import Client.Image.MircFormatting (parseIrcText')+import Client.Image.PackedImage (imageWidth, resizeImage, string, Image')+import Client.Image.Palette (palCommandPlaceholder, Palette)+import Control.Applicative.Free (runAp)+import Control.Lens (Const(..), view)+import Control.Monad.Trans.State (State, runState, state)+import Data.Functor.Compose (Compose(..))+import Data.Text qualified as Text+import Graphics.Vty (wcswidth)+import Graphics.Vty.Attributes (defAttr)  render ::   Palette  {- ^ palette             -} ->

src/Client/Commands/Arguments/Spec.hs view

@@ -24,8 +24,9 @@   , Arg(..)   ) where -import Control.Applicative-import Control.Applicative.Free+import Control.Applicative (liftA2)+import Control.Applicative.Free (Ap, liftAp)+import Data.Kind (Type) import Data.Maybe (fromMaybe) import Text.Read (readMaybe) @@ -33,7 +34,7 @@  data ArgumentShape = TokenArgument | RemainingArgument -data Arg :: * -> * -> * where+data Arg :: Type -> Type -> Type where   Argument  :: ArgumentShape -> String -> (r -> String -> Maybe a) -> Arg r a   Optional  :: Args r a -> Arg r (Maybe a)   Extension :: String -> (r -> String -> Maybe (Args r a)) -> Arg r a

src/Client/Commands/Certificate.hs view

@@ -9,27 +9,27 @@  module Client.Commands.Certificate (newCertificateCommand) where -import           Client.Commands.Arguments.Spec-import           Client.Commands.TabCompletion-import           Client.Commands.Types-import           Client.State-import           Control.Applicative-import           Control.Exception-import qualified Data.ByteString as B-import qualified Data.ByteString.Lazy as L-import           Data.Foldable (foldl')-import           Data.Maybe (fromMaybe)-import           Data.Text (Text)-import qualified Data.Text as Text-import           Data.Time-import           Hookup.OpenSSL (getPubKeyDer)-import qualified OpenSSL.RSA as RSA-import qualified OpenSSL.X509 as X509-import qualified OpenSSL.PEM as PEM-import qualified OpenSSL.EVP.Cipher as Cipher-import qualified OpenSSL.EVP.Digest as Digest-import           Text.Read (readMaybe)-import           Text.Printf (printf)+import Client.Commands.Arguments.Spec+import Client.Commands.TabCompletion (noClientTab)+import Client.Commands.Types+import Client.State (recordError, recordSuccess)+import Control.Applicative (liftA2)+import Control.Exception (displayException, try)+import Data.ByteString qualified as B+import Data.ByteString.Lazy qualified as L+import Data.Foldable (foldl')+import Data.Maybe (fromMaybe)+import Data.Text (Text)+import Data.Text qualified as Text+import Data.Time (UTCTime(UTCTime), Day(ModifiedJulianDay), getZonedTime)+import Hookup.OpenSSL (getPubKeyDer)+import OpenSSL.EVP.Cipher qualified as Cipher+import OpenSSL.EVP.Digest qualified as Digest+import OpenSSL.PEM qualified as PEM+import OpenSSL.RSA qualified as RSA+import OpenSSL.X509 qualified as X509+import Text.Printf (printf)+import Text.Read (readMaybe)  keysizeArg :: Args a (Maybe (Int, String)) keysizeArg = optionalArg (liftA2 (,) (tokenArg "[keysize]" (const parseSize)) (remainingArg "[passphrase]"))@@ -72,52 +72,54 @@  cmdNewCert :: ClientCommand (String, Maybe (Int, String)) cmdNewCert st (path, mbExtra) =-  do now <- getZonedTime+ do now <- getZonedTime -     let size = case mbExtra of-                  Nothing -> 2048-                  Just (n,_) -> n-     pass <- case mbExtra of-               Just (_,p) | not (null p) ->-                 do cipher <- fromMaybe (error "No aes128!") <$> Cipher.getCipherByName "aes128"-                    pure (Just (cipher, PEM.PwStr p))-               _ -> pure Nothing+    let size =+          case mbExtra of+            Nothing -> 2048+            Just (n,_) -> n+    pass <-+      case mbExtra of+        Just (_,p) | not (null p) ->+         do cipher <- fromMaybe (error "No aes128!") <$> Cipher.getCipherByName "aes128"+            pure (Just (cipher, PEM.PwStr p))+        _ -> pure Nothing -     rsa  <- RSA.generateRSAKey' size 65537-     x509 <- X509.newX509-     X509.setVersion      x509 2-     X509.setSerialNumber x509 1-     X509.setIssuerName   x509 [("CN","glirc")]-     X509.setSubjectName  x509 [("CN","glirc")]-     X509.setNotBefore    x509 (UTCTime (ModifiedJulianDay 40587) 0) -- 1970-01-01-     X509.setNotAfter     x509 (UTCTime (ModifiedJulianDay 77112) 0) -- 2070-01-01-     X509.setPublicKey    x509 rsa-     X509.signX509        x509 rsa Nothing+    rsa  <- RSA.generateRSAKey' size 65537+    x509 <- X509.newX509+    X509.setVersion      x509 2+    X509.setSerialNumber x509 1+    X509.setIssuerName   x509 [("CN","glirc")]+    X509.setSubjectName  x509 [("CN","glirc")]+    X509.setNotBefore    x509 (UTCTime (ModifiedJulianDay 40587) 0) -- 1970-01-01+    X509.setNotAfter     x509 (UTCTime (ModifiedJulianDay 77112) 0) -- 2070-01-01+    X509.setPublicKey    x509 rsa+    X509.signX509        x509 rsa Nothing -     ctder <- X509.writeDerX509 x509-     pkder <- getPubKeyDer x509-     msgss <- traverse (getFingerprint ctder pkder) ["sha1", "sha256", "sha512"]+    ctder <- X509.writeDerX509 x509+    pkder <- getPubKeyDer x509+    msgss <- traverse (getFingerprint ctder pkder) ["sha1", "sha256", "sha512"] -     pem1 <- PEM.writePKCS8PrivateKey rsa pass-     pem2 <- PEM.writeX509 x509-     res  <- try (writeFile path (pem1 ++ pem2))+    pem1 <- PEM.writePKCS8PrivateKey rsa pass+    pem2 <- PEM.writeX509 x509+    res  <- try (writeFile path (pem1 ++ pem2)) -     case res of-       Left e ->-        commandFailure (recordError now "" (Text.pack (displayException (e :: IOError))) st)-       Right () ->-        do let msg = "Certificate saved: \x02" <> path <> "\x02"-           commandSuccess (foldl' (recordSuccess now) st (concat msgss ++ [Text.pack msg]))+    case res of+      Left e ->+          commandFailure (recordError now "" (Text.pack (displayException (e :: IOError))) st)+      Right () ->+       do let msg = "Certificate saved: \x02" <> path <> "\x02"+          commandSuccess (foldl' (recordSuccess now) st (concat msgss ++ [Text.pack msg]))  getFingerprint :: L.ByteString -> B.ByteString -> String -> IO [Text] getFingerprint crt pub name =-  do mb <- Digest.getDigestByName name-     pure $ case mb of-       Nothing -> []-       Just d  -> map Text.pack-         [printf "CERT %-6s fingerprint: \^C07%s" name (hexString (Digest.digestLBS d crt))-         ,printf "SPKI %-6s fingerprint: \^C07%s" name (hexString (Digest.digestBS  d pub))-         ]+ do mb <- Digest.getDigestByName name+    pure $! case mb of+      Nothing -> []+      Just d  -> map Text.pack+        [ printf "CERT %-6s fingerprint: \^C07%s" name (hexString (Digest.digestLBS d crt))+        , printf "SPKI %-6s fingerprint: \^C07%s" name (hexString (Digest.digestBS  d pub))+        ]  hexString :: B.ByteString -> String hexString = B.foldr (printf "%02x%s") ""

src/Client/Commands/Channel.hs view

@@ -9,30 +9,29 @@  module Client.Commands.Channel (channelCommands) where -import           Client.Commands.Arguments.Spec-import           Client.Commands.TabCompletion-import           Client.Commands.Types-import           Client.Commands.WordCompletion-import           Client.State-import           Client.State.Channel-import           Client.State.Focus-import           Client.State.Network-import           Client.UserHost-import           Control.Applicative-import           Control.Lens-import           Control.Monad-import           Data.Foldable (traverse_)-import           Data.List.Split (chunksOf)-import           Data.Maybe (fromMaybe)-import           Data.Text (Text)-import qualified Client.State.EditBox as Edit-import qualified Data.HashMap.Strict as HashMap-import qualified Data.Text as Text-import           Irc.Commands-import           Irc.Modes-import           Irc.UserInfo-import           Irc.Identifier-import           LensUtils (setStrict)+import Client.Commands.Arguments.Spec+import Client.Commands.TabCompletion (activeNicks, noChannelTab, simpleChannelTab, simpleTabCompletion)+import Client.Commands.Types+import Client.Commands.WordCompletion (plainWordCompleteMode)+import Client.State+import Client.State.Channel (chanLists, chanModes, chanTopic, chanUsers)+import Client.State.EditBox qualified as Edit+import Client.State.Focus+import Client.State.Network+import Client.UserHost ( UserAndHost(UserAndHost) )+import Control.Applicative (liftA2)+import Control.Lens+import Control.Monad (unless)+import Data.Foldable (traverse_)+import Data.HashMap.Strict qualified as HashMap+import Data.List.Split (chunksOf)+import Data.Maybe (fromMaybe)+import Data.Text (Text)+import Data.Text qualified as Text+import Irc.Commands (ircInvite, ircKick, ircMode, ircRemove)+import Irc.Identifier (Identifier, mkId)+import Irc.Modes+import Irc.UserInfo (UserInfo(UserInfo), renderUserInfo)  channelCommands :: CommandSection channelCommands = CommandSection "IRC channel management"@@ -150,12 +149,6 @@               then cs <$ sendMsg cs cmd               else sendModeration channelId [cmd] cs      commandSuccessUpdateCS cs' st--commandSuccessUpdateCS :: NetworkState -> ClientState -> IO CommandResult-commandSuccessUpdateCS cs st =-  do let network = view csNetwork cs-     commandSuccess-       $ setStrict (clientConnection network) cs st  cmdMasks :: ChannelCommand String cmdMasks channel cs st rest =

src/Client/Commands/Chat.hs view

@@ -9,28 +9,28 @@  module Client.Commands.Chat (chatCommands, chatCommand', executeChat, cmdCtcp) where -import           Client.Commands.Arguments.Spec-import           Client.Commands.TabCompletion-import           Client.Commands.Types-import           Client.Commands.Window (parseFocus)-import           Client.Message-import           Client.State-import           Client.State.Extensions (clientChatExtension)-import           Client.State.Focus-import           Client.State.Network-import           Control.Applicative-import           Control.Lens-import           Control.Monad (when)-import           Data.Char (toUpper)-import           Data.Foldable-import           Data.List.NonEmpty (NonEmpty((:|)))-import           Data.Text (Text)-import qualified Data.Text as Text-import           Data.Time-import           Irc.Commands-import           Irc.Identifier-import           Irc.Message-import           Irc.RawIrcMsg+import Client.Commands.Arguments.Spec+import Client.Commands.TabCompletion+import Client.Commands.Types+import Client.Commands.Window (parseFocus)+import Client.Message+import Client.State+import Client.State.Extensions (clientChatExtension)+import Client.State.Focus (focusNetwork, Focus(ChannelFocus), Subfocus(FocusInfo, FocusUsers))+import Client.State.Network (csNetwork, csUserInfo, sendMsg, NetworkState)+import Control.Applicative (liftA2, liftA3)+import Control.Lens (view, preview, views)+import Control.Monad (when)+import Data.Char (toUpper)+import Data.Foldable (foldl')+import Data.List.NonEmpty (NonEmpty((:|)))+import Data.Text (Text)+import Data.Text qualified as Text+import Data.Time (getZonedTime)+import Irc.Commands+import Irc.Identifier (Identifier, idText, mkId)+import Irc.Message (IrcMsg(Privmsg, Notice, Ctcp), Source(Source))+import Irc.RawIrcMsg (RawIrcMsg, parseRawIrcMsg)  chatCommands :: CommandSection chatCommands = CommandSection "IRC commands"

src/Client/Commands/Connection.hs view

@@ -9,18 +9,18 @@  module Client.Commands.Connection (connectionCommands) where -import           Client.Commands.Arguments.Spec-import           Client.Commands.TabCompletion-import           Client.Commands.Types-import           Client.Commands.WordCompletion-import           Client.Configuration-import           Client.State-import           Client.State.Focus-import           Client.State.Network-import           Control.Lens-import qualified Data.HashMap.Strict as HashMap-import qualified Data.Text as Text-import           Irc.Commands (ircMode, ircQuit)+import Client.Commands.Arguments.Spec ( remainingArg, simpleToken )+import Client.Commands.TabCompletion+import Client.Commands.Types+import Client.Commands.WordCompletion ( plainWordCompleteMode )+import Client.Configuration ( configServers )+import Client.State+import Client.State.Focus (focusNetwork, Focus(NetworkFocus), Subfocus(FocusCert))+import Client.State.Network (csLastReceived, csNetwork, csNick, sendMsg)+import Control.Lens (view, folded, preview, views)+import Data.HashMap.Strict qualified as HashMap+import Data.Text qualified as Text+import Irc.Commands (ircMode, ircQuit)  connectionCommands :: CommandSection connectionCommands = CommandSection "Connection commands"

src/Client/Commands/Exec.hs view

@@ -25,11 +25,14 @@   , runExecCmd   ) where -import           Control.Exception-import           Control.Lens-import           Data.List-import           System.Console.GetOpt-import           System.Process+import Control.Exception (Exception(displayException), try)+import Control.Lens (view, (??), set, makeLenses)+import Data.ByteString.Lazy qualified as L+import Data.List (unfoldr)+import Data.Text qualified as Text+import Data.Text.Encoding qualified as Text+import System.Console.GetOpt (getOpt, ArgDescr(ReqArg, OptArg), ArgOrder(RequireOrder), OptDescr(..))+import System.Process.Typed (byteStringInput, proc, readProcessStdout_, setStdin)  -- | Settings for @/exec@ command. --@@ -103,13 +106,15 @@   ExecCmd                       {- ^ exec configuration          -} ->   IO (Either [String] [String]) {- ^ error lines or output lines -} runExecCmd cmd =-  do res <- try (readProcessWithExitCode-                   (view execCommand   cmd)-                   (view execArguments cmd)-                   (view execStdIn     cmd))+  do res <- try (readProcessStdout_+                   (setStdin (byteStringInput (L.fromStrict (Text.encodeUtf8 (Text.pack (view execStdIn cmd)))))+                   (proc (view execCommand   cmd) (view execArguments cmd))))      return $! case res of-       Left er                  -> Left [displayException (er :: IOError)]-       Right (_code, out, _err) -> Right (lines out)+       Left er   -> Left [displayException (er :: IOError)]+       Right out ->+          case Text.decodeUtf8' (L.toStrict out) of+             Right str -> Right (lines (Text.unpack str))+             Left e -> Left [displayException e]  -- | Power words is similar to 'words' except that when it encounters -- a word formatted as a Haskell 'String' literal it parses it as

src/Client/Commands/Interpolation.hs view

@@ -28,14 +28,13 @@   , noMacroArguments   ) where -import           Control.Applicative-import           Data.Attoparsec.Text as P-import           Data.Char-import           Data.Maybe-import qualified Data.Text as Text-import           Data.Text (Text)--import           Client.Commands.Arguments.Spec+import Client.Commands.Arguments.Spec (optionalArg, remainingArg, simpleToken, Args)+import Control.Applicative (Alternative, liftA2, (<|>), many, optional)+import Data.Attoparsec.Text as P+import Data.Char (isAlpha)+import Data.Maybe (fromMaybe)+import Data.Text (Text)+import Data.Text qualified as Text  -- | Parsed chunk of an expandable command data ExpansionChunk

src/Client/Commands/Operator.hs view

@@ -9,15 +9,15 @@  module Client.Commands.Operator (operatorCommands) where -import           Control.Applicative-import           Client.Commands.Arguments.Spec-import           Client.Commands.TabCompletion-import           Client.Commands.Types-import           Client.State.Network (sendMsg)-import           Data.Maybe (fromMaybe, maybeToList)-import qualified Data.Text as Text-import           Irc.Commands-import           Irc.RawIrcMsg+import Client.Commands.Arguments.Spec (optionalArg, remainingArg, simpleToken)+import Client.Commands.TabCompletion (noNetworkTab, simpleNetworkTab)+import Client.Commands.Types+import Client.State.Network (sendMsg)+import Control.Applicative (liftA2, liftA3)+import Data.Maybe (fromMaybe, maybeToList)+import Data.Text qualified as Text+import Irc.Commands+import Irc.RawIrcMsg (rawIrcMsg)  operatorCommands :: CommandSection operatorCommands = CommandSection "Network operator commands"

src/Client/Commands/Queries.hs view

@@ -1,4 +1,6 @@ {-# Language OverloadedStrings #-}+{-# LANGUAGE BlockArguments #-}+{-# LANGUAGE ViewPatterns #-} {-| Module      : Client.Commands.Queries Description : Query command implementations@@ -9,20 +11,27 @@  module Client.Commands.Queries (queryCommands) where -import           Client.Commands.Arguments.Spec-import           Client.Commands.TabCompletion-import           Client.Commands.Types-import           Client.State.Network (sendMsg)-import qualified Data.Text as Text-import           Irc.Commands+import Client.Commands.Arguments.Spec (optionalArg, remainingArg, simpleToken, extensionArg, Args)+import Client.Commands.TabCompletion (noNetworkTab, simpleNetworkTab)+import Client.Commands.Types (commandSuccess, commandSuccessUpdateCS, Command(Command), CommandImpl(NetworkCommand), CommandSection(CommandSection), NetworkCommand)+import Client.State (changeSubfocus, ClientState)+import Client.State.Focus (Subfocus(FocusChanList, FocusWho))+import Client.State.Network (sendMsg, csChannelList, clsElist, csPingStatus, _PingConnecting, csWhoReply)+import Client.WhoReply (newWhoReply)+import Control.Applicative (liftA2)+import Control.Lens (has, set, view)+import Control.Monad (unless)+import Data.Maybe (fromMaybe, maybeToList)+import Data.Text qualified as Text+import Irc.Commands  queryCommands :: CommandSection queryCommands = CommandSection "Queries"    [ Command       (pure "who")-      (remainingArg "arguments")-      "Send WHO query to server with given arguments.\n"+      (optionalArg (liftA2 (,) (simpleToken "[channel|nick|mask]") (optionalArg (simpleToken "[options]"))))+      "Send WHO query to server with given arguments, or just show the who view.\n"     $ NetworkCommand cmdWho simpleNetworkTab    , Command@@ -94,8 +103,32 @@     $ NetworkCommand cmdInfo noNetworkTab    , Command-      (pure "list") (remainingArg "arguments")-      "Send LIST query to server.\n"+      (pure "list")+      (optionalArg (extensionArg "[clientarg]" listArgs))+      "\^BParameters:\^B\n\+      \\n\+      \    clientarg: An optionally-comma-separated list of\n\+      \               flags for controlling the list.\n\+      \        ~: Always refresh the list.\n\+      \        >n: Show only channels with more than \^Bn\^B users.\n\+      \        <n: Show only channels with less than \^Bn\^B users.\n\+      \\n\+      \    serverarg: The ELIST argument to send to the server.\n\+      \\n\+      \\^BDescription:\^B\n\+      \\n\+      \    View the list of public channels on the server.\n\+      \\n\+      \    Sends a LIST query and caches the result;\n\+      \    on larger networks on slower connections,\n\+      \    this may take a while to complete.\n\+      \\n\+      \\^BExamples:\^B\n\+      \\n\+      \    /list\n\+      \    /list >100\n\+      \    /list ~ <20\n\+      \    /list , *-ops"     $ NetworkCommand cmdList simpleNetworkTab    , Command@@ -123,11 +156,51 @@                                 Nothing -> ""      commandSuccess st -cmdList :: NetworkCommand String+cmdList :: NetworkCommand (Maybe ListArgs) cmdList cs st rest =-  do sendMsg cs (ircList (Text.pack <$> words rest))-     commandSuccess st+    do+      let lsa = fromMaybe lsaDefault rest+      let connecting = has (csPingStatus . _PingConnecting) cs+      let elist = Just (Text.pack (fromMaybe "" (_lsaElist lsa)))+      let cached = elist == view (csChannelList . clsElist) cs+      let sendM = sendMsg cs (ircList (Text.pack <$> maybeToList (_lsaElist lsa)))+      unless (connecting || (cached && not (_lsaRefresh lsa))) sendM+      let cs' = set (csChannelList . clsElist) elist cs +      let subfocus = FocusChanList (_lsaMin lsa) (_lsaMax lsa)+      commandSuccessUpdateCS cs' (changeSubfocus subfocus st) +listArgs :: ClientState -> String -> Maybe (Args ClientState ListArgs)+listArgs _ = fmap (withElist (optionalArg (simpleToken "[serverarg]"))) . lsaParse+    where withElist arg a = fmap (\s -> a { _lsaElist = s }) arg++data ListArgs = ListArgs+  { _lsaElist   :: Maybe String+  , _lsaRefresh :: Bool+  , _lsaMin     :: Maybe Int+  , _lsaMax     :: Maybe Int+  }++lsaDefault :: ListArgs+lsaDefault = ListArgs+  { _lsaElist = Nothing+  , _lsaRefresh = False+  , _lsaMin = Nothing+  , _lsaMax = Nothing+  }++lsaParse :: String -> Maybe ListArgs+lsaParse = lsaParse' lsaDefault+  where+    lsaParse' lsa str = case str of+      '~':rest -> lsaParse' lsa{ _lsaRefresh = True } rest+      ',':rest -> lsaParse' lsa rest+      '>':(reads -> [(min', rest)]) | min' >= 0 ->+        lsaParse' lsa{ _lsaMin = Just min'} rest+      '<':(reads -> [(max', rest)]) | max' >= 0 ->+        lsaParse' lsa{ _lsaMax = Just max'} rest+      "" -> Just lsa+      _ -> Nothing+ cmdLusers :: NetworkCommand (Maybe String) cmdLusers cs st arg =   do sendMsg cs $ ircLusers $ fmap Text.pack $@@ -183,10 +256,15 @@   do sendMsg cs (ircWhois (Text.pack <$> words rest))      commandSuccess st -cmdWho :: NetworkCommand String-cmdWho cs st rest =-  do sendMsg cs (ircWho (Text.pack <$> words rest))-     commandSuccess st+cmdWho :: NetworkCommand (Maybe (String, Maybe String))+cmdWho _  st Nothing = commandSuccess (changeSubfocus FocusWho st)+cmdWho cs st (Just (query, arg)) =+  do+    let query' = Text.pack query+    let arg' = fromMaybe "" arg+    let cs' = set csWhoReply (newWhoReply query' arg') cs+    sendMsg cs (ircWho (query' : maybeToList (Text.pack <$> arg)))+    commandSuccessUpdateCS cs' (changeSubfocus FocusWho st)  cmdWhowas :: NetworkCommand String cmdWhowas cs st rest =

src/Client/Commands/Recognizer.hs view

@@ -21,14 +21,12 @@   , keys   ) where -import Control.Monad import Control.Applicative hiding (empty)--import           Data.HashMap.Strict (lookup,insertWith,HashMap,empty,unionWith,fromList,toList)-import           Data.Text (Text)-import qualified Data.Text as Text-import           Data.Maybe-+import Control.Monad (guard)+import Data.HashMap.Strict (lookup,insertWith,HashMap,empty,unionWith,fromList,toList)+import Data.Maybe (fromMaybe, maybeToList)+import Data.Text (Text)+import Data.Text qualified as Text import Prelude hiding (all,lookup)  -- | A map from 'Text' values to 'a' values that is capable of yielding more

src/Client/Commands/TabCompletion.hs view

@@ -8,18 +8,18 @@  module Client.Commands.TabCompletion where -import           Client.Commands.Types-import           Client.Commands.WordCompletion-import           Client.Message-import           Client.State-import           Client.State.Focus-import           Client.State.Network-import           Client.State.Window-import           Client.State.Channel-import           Control.Lens+import Client.Commands.Types+import Client.Commands.WordCompletion (wordComplete, Prefix, WordCompletionMode)+import Client.Message (IrcSummary(ChatSummary))+import Client.State+import Client.State.Channel (chanUsers)+import Client.State.Focus (Focus(ChannelFocus))+import Client.State.Network (csChannels, csNick)+import Client.State.Window (winMessages, wlSummary)+import Control.Lens (view, filtered, folding, preview, toListOf, traverseOf, Ixed(ix), Each(each))+import Irc.Identifier (Identifier)+import Irc.UserInfo (UserInfo(userNick)) import qualified Data.HashMap.Strict as HashMap-import           Irc.Identifier-import           Irc.UserInfo  -- | Provides no tab completion for client commands noClientTab :: Bool -> ClientCommand String

src/Client/Commands/Toggles.hs view

@@ -9,11 +9,11 @@  module Client.Commands.Toggles (togglesCommands) where -import           Client.Commands.TabCompletion-import           Client.Commands.Types-import           Client.Configuration-import           Client.State-import           Control.Lens+import Client.Commands.TabCompletion (noClientTab)+import Client.Commands.Types+import Client.Configuration (EditMode(SingleLineEditor, MultiLineEditor), LayoutMode(OneColumn, TwoColumn))+import Client.State+import Control.Lens (over, set)  togglesCommands :: CommandSection togglesCommands = CommandSection "View toggles"

src/Client/Commands/Types.hs view

@@ -9,13 +9,14 @@  module Client.Commands.Types where -import           Client.State (ClientState, clientErrorMsg)-import           Client.State.Network (NetworkState)-import           Data.Text (Text)-import           Data.List.NonEmpty (NonEmpty)-import           Client.Commands.Arguments.Spec-import           Irc.Identifier (Identifier)-import           Control.Lens+import Client.Commands.Arguments.Spec (Args)+import Client.State (ClientState, clientErrorMsg, clientConnection)+import Client.State.Network (NetworkState, csNetwork)+import Control.Lens (set, view)+import Data.List.NonEmpty (NonEmpty)+import Data.Text (Text)+import Irc.Identifier (Identifier)+import LensUtils (setStrict)  -- | Possible results of running a command data CommandResult@@ -75,6 +76,14 @@ -- | Consider the text entry successful and resume the client commandSuccess :: Monad m => ClientState -> m CommandResult commandSuccess = return . CommandSuccess++-- | Consider the text entry successful, and resume the client with+-- a particular network updated.+commandSuccessUpdateCS :: NetworkState -> ClientState -> IO CommandResult+commandSuccessUpdateCS cs st =+  do let network = view csNetwork cs+     commandSuccess+       $ setStrict (clientConnection network) cs st  -- | Consider the text entry a failure and resume the client commandFailure :: Monad m => ClientState -> m CommandResult

src/Client/Commands/Window.hs view

@@ -9,30 +9,30 @@  module Client.Commands.Window (windowCommands, parseFocus) where -import           Client.Commands.Arguments.Spec-import           Client.Commands.TabCompletion-import           Client.Commands.Types-import           Client.Commands.WordCompletion-import           Client.Mask (buildMask)-import           Client.State-import           Client.State.Focus-import           Client.State.Network-import           Client.State.Window (windowClear, wlText, winMessages, winHidden, winSilent, winName)-import           Control.Applicative-import           Control.Exception-import           Control.Lens-import           Data.Foldable-import           Data.List ((\\), nub)-import qualified Client.State.EditBox as Edit-import           Data.HashSet (HashSet)-import           Data.List.NonEmpty (NonEmpty((:|)))-import qualified Data.HashMap.Strict as HashMap-import qualified Data.Map as Map-import           Data.Text (Text)-import qualified Data.Text as Text-import qualified Data.Text.Lazy as LText-import qualified Data.Text.Lazy.IO as LText-import           Irc.Identifier+import Client.Commands.Arguments.Spec+import Client.Commands.TabCompletion+import Client.Commands.Types+import Client.Commands.WordCompletion (plainWordCompleteMode)+import Client.Mask (buildMask)+import Client.State+import Client.State.EditBox qualified as Edit+import Client.State.Focus+import Client.State.Network (csChannels)+import Client.State.Window (windowClear, wlText, winMessages, winHidden, winActivityFilter, winName, activityFilterStrings, readActivityFilter)+import Control.Applicative (liftA2)+import Control.Exception (SomeException, Exception(displayException), try)+import Control.Lens+import Data.Foldable (Foldable(foldl', toList))+import Data.HashMap.Strict qualified as HashMap+import Data.HashSet (HashSet)+import Data.List ((\\), nub)+import Data.List.NonEmpty (NonEmpty((:|)))+import Data.Map qualified as Map+import Data.Text (Text)+import Data.Text qualified as Text+import Data.Text.Lazy qualified as LText+import Data.Text.Lazy.IO qualified as LText+import Irc.Identifier (Identifier, idText, mkId)  windowCommands :: CommandSection windowCommands = CommandSection "Window management"@@ -228,12 +228,18 @@    , Command       (pure "setwindow")-      (simpleToken "hide|show|loud|silent")+      (simpleToken ("hide|show" ++ concatMap ('|':) activityFilterStrings))       "Set window property.\n\       \\n\-      \\^Bloud\^B / \^Bsilent\^B\n\-      \    Toggles if window activity appears in the status bar.\n\-      \n\+      \\^Bsilent\^B / \^Bquieter\^B / \^Bquiet\^B / \^Bimponly\^B / \^Bloud\^B / \^Blouder\^B\n\+      \    Changes the importance of normal and important messages:\n\+      \      \^Blouder\^B: Upgrades normal to important.\n\+      \      \^Bloud\^B: Uses default values.\n\+      \      \^Bimponly\^B: Downgrades normal to boring.\n\+      \      \^Bquiet\^B: Downgrades important to normal.\n\+      \      \^Bquieter\^B: Downgrades both one step.\n\+      \      \^Bsilent\^B: Downgrades both to boring.\n\+      \\n\       \\^Bshow\^B / \^Bhide\^B\n\       \    Toggles if window appears in window command shortcuts.\n"     $ ClientCommand cmdSetWindow tabSetWindow@@ -256,7 +262,7 @@   case mbSt1 of     Nothing -> commandFailureMsg "no current window" st     Just st1 ->-      let next = clientNextWindowName st+      let next = clientNextWindowName (clientWindowHint (view clientFocus st) st) st           mbName =             case arg of               Just [n] | n `elem` clientWindowNames st -> Right n@@ -284,17 +290,15 @@   where     mbFun =       case cmd of-        "show"   -> Just (set winHidden False)-        "hide"   -> Just (set winName Nothing . set winHidden True)-        "loud"   -> Just (set winSilent False)-        "silent" -> Just (set winSilent True)-        _        -> Nothing+        "show"    -> Just (set winHidden False)+        "hide"    -> Just (set winName Nothing . set winHidden True)+        other     -> set winActivityFilter <$> readActivityFilter other  tabSetWindow :: Bool {- ^ reversed -} -> ClientCommand String tabSetWindow isReversed st _ =   simpleTabCompletion plainWordCompleteMode [] completions isReversed st   where-    completions = ["hide", "show", "loud", "silent"] :: [Text]+    completions = "hide":"show": map Text.pack activityFilterStrings  -- | Implementation of @/grep@ cmdGrep :: ClientCommand String

src/Client/Commands/WordCompletion.hs view

@@ -21,16 +21,16 @@   , CaseText, caseText   ) where -import qualified Client.State.EditBox as Edit-import           Control.Applicative-import           Control.Lens-import           Control.Monad-import           Data.List-import qualified Data.Set as Set-import           Data.String (IsString(..))-import qualified Data.Text as Text-import           Data.Text (Text)-import           Irc.Identifier+import Client.State.EditBox qualified as Edit+import Control.Applicative ((<|>))+import Control.Lens (view, over, set)+import Control.Monad (guard)+import Data.List (find)+import Data.Set qualified as Set+import Data.String (IsString(..))+import Data.Text (Text)+import Data.Text qualified as Text+import Irc.Identifier (Identifier, idPrefix, idText)  -- | Word completion prefix and suffix data WordCompletionMode = WordCompletionMode

src/Client/Commands/ZNC.hs view

@@ -9,17 +9,16 @@  module Client.Commands.ZNC (zncCommands) where -import           Control.Applicative-import           Client.Commands.Arguments.Spec-import           Client.Commands.TabCompletion-import           Client.Commands.Types-import           Client.State.Network (sendMsg)-import           Data.Foldable (asum)-import qualified Data.Text as Text-import           Data.Time-import           Irc.Commands-import           Control.Lens-import           LensUtils (localTimeDay, localTimeTimeOfDay, zonedTimeLocalTime)+import Control.Applicative (asum, liftA2)+import Client.Commands.Arguments.Spec (optionalArg, remainingArg, simpleToken)+import Client.Commands.TabCompletion (noNetworkTab, simpleNetworkTab)+import Client.Commands.Types+import Client.State.Network (sendMsg)+import Data.Text qualified as Text+import Data.Time+import Irc.Commands (ircZnc)+import Control.Lens ((<<.~), (??), over)+import LensUtils (localTimeDay, localTimeTimeOfDay, zonedTimeLocalTime)  zncCommands :: CommandSection zncCommands = CommandSection "ZNC Support"

src/Client/Configuration.hs view

@@ -46,7 +46,9 @@   , configShowPing   , configJumpModifier   , configDigraphs+  , configNotifications +  , configNetworkPalette   , extensionPath   , extensionRtldFlags   , extensionArgs@@ -70,37 +72,37 @@   , UrlArgument(..)   ) where -import           Client.Commands.Interpolation-import           Client.Commands.Recognizer-import           Client.Configuration.Colors-import           Client.Configuration.Macros (macroMapSpec)-import           Client.Configuration.ServerSettings-import           Client.EventLoop.Actions-import           Client.Image.Palette-import           Config-import           Config.Macro-import           Config.Schema-import           Control.Exception-import           Control.Lens                        hiding (List)-import           Data.Foldable                       (foldl', toList)-import           Data.HashMap.Strict                 (HashMap)-import qualified Data.HashMap.Strict                 as HashMap-import qualified Data.List.NonEmpty                  as NonEmpty-import           Data.Map                            (Map)-import qualified Data.Map                            as Map-import           Data.Maybe-import           Data.Monoid                         (Endo(..))-import           Data.Text                           (Text)-import qualified Data.Text                           as Text-import qualified Data.Vector                         as Vector-import           Digraphs (Digraph(..))-import           Graphics.Vty.Input.Events (Modifier(..), Key(..))-import           Graphics.Vty.Attributes             (Attr)-import           Irc.Identifier                      (Identifier)-import           System.Directory-import           System.FilePath-import           System.Posix.DynamicLinker          (RTLDFlags(..))-import           System.IO.Error+import Client.Commands.Interpolation (Macro)+import Client.Commands.Recognizer (Recognizer)+import Client.Configuration.Colors (attrSpec)+import Client.Configuration.Macros (macroMapSpec)+import Client.Configuration.Notifications (NotifyWith, notifySpec, notifyWithDefault)+import Client.Configuration.ServerSettings+import Client.EventLoop.Actions+import Client.Image.Palette+import Config+import Config.Macro+import Config.Schema+import Control.Exception+import Control.Lens hiding (List)+import Data.Foldable (foldl', toList)+import Data.HashMap.Strict (HashMap)+import Data.HashMap.Strict qualified as HashMap+import Data.List.NonEmpty qualified as NonEmpty+import Data.Map  (Map)+import Data.Map qualified as Map+import Data.Maybe (fromMaybe, isNothing)+import Data.Monoid (Endo(..))+import Data.Text (Text)+import Data.Text qualified as Text+import Data.Vector qualified as Vector+import Digraphs (Digraph(..))+import Graphics.Vty.Input.Events (Modifier(..), Key(..))+import Irc.Identifier (Identifier, mkId)+import System.Directory ( getHomeDirectory, getXdgDirectory, XdgDirectory(XdgConfig))+import System.FilePath ((</>), isAbsolute, joinPath, splitDirectories, takeDirectory)+import System.IO.Error (ioeGetFileName, isDoesNotExistError)+import System.Posix.DynamicLinker (RTLDFlags(..))  -- | Top-level client configuration information. When connecting to a -- server configuration from '_configServers' is used where possible,@@ -125,6 +127,7 @@   , _configShowPing        :: Bool -- ^ visibility of ping time   , _configJumpModifier    :: [Modifier] -- ^ Modifier used for jumping windows   , _configDigraphs        :: Map Digraph Text -- ^ Extra digraphs+  , _configNotifications   :: NotifyWith   }   deriving Show @@ -294,6 +297,8 @@                                "Initial setting for visibility of ping times"      _configDigraphs        <- sec' mempty "extra-digraphs" (Map.fromList <$> listSpec digraphSpec)                                "Extra digraphs"+     _configNotifications   <- sec' notifyWithDefault "notifications" notifySpec+                               "Whether and how to show desktop notifications"      return (\def ->              let _configDefaults = snd ssDefUpdate def                  _configServers  = buildServerMap _configDefaults ssUpdates@@ -403,29 +408,18 @@     nickColorsSpec = set palNicks . Vector.fromList . NonEmpty.toList                  <$> nonemptySpec attrSpec -    modeColorsSpec :: Lens' Palette (HashMap Char Attr) -> ValueSpec (Palette -> Palette)-    modeColorsSpec l-      = fmap (set l)-      $ customSpec "modes" (assocSpec attrSpec)-      $ fmap HashMap.fromList-      . traverse (\(mode, attr) ->-          case Text.unpack mode of-            [m] -> Right (m, attr)-            _   -> Left "expected single letter")+    idOverridesSpec = set palIdOverride . HashMap.fromList . concat <$> listSpec idOverrideSpec+    idOverrideSpec =+      sectionsSpec "ids-to-attr" $+      do ids <- reqSection' "ids" (oneOrList stringSpec) "One or more identifiers that this override applies to."+         attr <- reqSection' "color" attrSpec "The style to use."+         pure [(mkId $ Text.pack id', attr) | id' <- ids]      fields :: [SectionsSpec (Maybe (Palette -> Palette))]-    fields = optSection' "nick-colors" nickColorsSpec-             "Colors used to highlight nicknames"--           : optSection' "cmodes" (modeColorsSpec palCModes)-             "Colors used to highlight channel modes"--           : optSection' "umodes" (modeColorsSpec palUModes)-             "Colors used to highlight user modes"--           : optSection' "snomask" (modeColorsSpec palSnomask)-             "Colors used to highlight server notice mask"-+    fields = optSection' "identifier-colors" nickColorsSpec+             "Colors used to highlight identifiers (nicks, channel names)."+           : optSection' "identifier-overrides" idOverridesSpec+             "Colors used to highlight specific identifiers (nicks, channel names)."            : [ optSection' lbl (set l <$> attrSpec) "" | (lbl, Lens l) <- paletteMap ]  extensionSpec :: ValueSpec ExtensionConfiguration@@ -529,3 +523,10 @@   | isAbsolute path                   = path   | "~":rest <- splitDirectories path = joinPath (fpHome fpc : rest)   | otherwise                         = fpBase fpc </> path++-- | Returns a NetworkPalette for the given network name.+configNetworkPalette :: Text -> Configuration -> NetworkPalette+configNetworkPalette net cfg = unifyNetworkPalette palDefault $ fromMaybe defaultNetworkPalette palNet+  where+    palNet = view ssPalette <$> view (configServers . at net) cfg+    palDefault = view (configDefaults. ssPalette) cfg

src/Client/Configuration/Colors.hs view

@@ -1,5 +1,4 @@-{-# Language OverloadedStrings #-}-{-# Language ApplicativeDo #-}+{-# Language OverloadedStrings, ApplicativeDo, LambdaCase, BlockArguments #-}  {-| Module      : Client.Configuration@@ -16,11 +15,11 @@   , attrSpec   ) where -import           Config.Schema-import           Data.HashMap.Strict (HashMap)-import qualified Data.HashMap.Strict as HashMap-import           Data.Text (Text)-import           Graphics.Vty.Attributes+import Config.Schema+import Data.HashMap.Strict (HashMap)+import Data.HashMap.Strict qualified as HashMap+import Data.Text (Text)+import Graphics.Vty.Attributes  -- | Parse a text attribute. This value should be a sections with the @fg@ and/or -- @bg@ attributes. Otherwise it should be a color entry that will be used@@ -83,10 +82,9 @@ -- | Configuration section that matches 3 integers in the range 0-255 -- representing red, green, and blue values. rgbSpec :: ValueSpec Color-rgbSpec = customSpec "RGB" anySpec $ \rgb ->-  case rgb of-    [r,g,b] -> rgbColor <$> valid r <*> valid g <*> valid b-    _ -> Left "expected 3 numbers"+rgbSpec = customSpec "RGB" anySpec \case+  [r,g,b] -> rgbColor <$> valid r <*> valid g <*> valid b+  _       -> Left "expected 3 numbers"   where     valid x       | x < 0     = Left "minimum color value is 0"

src/Client/Configuration/Macros.hs view

@@ -14,11 +14,11 @@   , macroCommandSpec   ) where -import           Config.Schema.Spec-import           Client.Commands.Interpolation-import           Client.Commands.Recognizer-import           Data.Maybe (fromMaybe)-import           Data.Text (Text)+import Client.Commands.Interpolation+import Client.Commands.Recognizer (fromCommands, Recognizer)+import Config.Schema.Spec+import Data.Maybe (fromMaybe)+import Data.Text (Text)  macroMapSpec :: ValueSpec (Recognizer Macro) macroMapSpec = fromCommands <$> listSpec macroValueSpec

+ src/Client/Configuration/Notifications.hs view

@@ -0,0 +1,51 @@+{-# Language OverloadedStrings #-}+{-|+Module      : Client.Configuration.Notifications+Description : Options for running commands to notify users+Copyright   : (c) TheDaemoness, 2023+License     : ISC+Maintainer  : emertens@gmail.com+-}+module Client.Configuration.Notifications ( NotifyWith(..), notifyCmd, notifySpec, notifyWithDefault ) where++import           Config.Schema (ValueSpec, atomSpec, nonemptySpec, stringSpec, (<!>))+import qualified Data.Text.Lazy as LText+import           System.Process.Typed (ProcessConfig, proc, setEnv)+import           System.Info (os)+import qualified Data.List.NonEmpty as NonEmpty++data NotifyWith+  = NotifyWithCustom [String]+  | NotifyWithNotifySend+  | NotifyWithOsaScript+  | NotifyWithTerminalNotifier+  deriving Show++notifyCmd :: NotifyWith -> Maybe ((LText.Text, LText.Text) -> ProcessConfig () () ())+notifyCmd (NotifyWithCustom (cmd:args)) = Just $ \(header, body) ->+  proc cmd (args ++ [LText.unpack header, LText.unpack body])+notifyCmd NotifyWithNotifySend = Just $ \(header, body) ->+  proc "notify-send" ["-a", "glirc", LText.unpack header, LText.unpack body]+notifyCmd NotifyWithOsaScript = Just $ \(header, body) ->+  setEnv [("_GLIRC_NOTIF_HEADER", LText.unpack header), ("_GLIRC_NOTIF_BODY", LText.unpack body)] $+  proc "osascript" ["-e", script]+  where+    script = "display notification (system attribute \"_GLIRC_NOTIF_BODY\") with title \"glirc\" subtitle (system attribute \"_GLIRC_NOTIF_HEADER\")"+notifyCmd NotifyWithTerminalNotifier = Just $ \(header, body) ->+  proc "terminal-notifier" ["-title", "glirc", "-subtitle", LText.unpack header, "-message", "\\" <> LText.unpack body]+notifyCmd _ = Nothing++notifyWithDefault :: NotifyWith+notifyWithDefault = case os of+  "darwin" -> NotifyWithOsaScript+  "linux"  -> NotifyWithNotifySend+  _        -> NotifyWithCustom []++notifySpec :: ValueSpec NotifyWith+notifySpec =+  NotifyWithCustom []        <$ atomSpec "no"  <!>+  notifyWithDefault          <$ atomSpec "yes" <!>+  NotifyWithNotifySend       <$ atomSpec "notify-send" <!>+  NotifyWithOsaScript        <$ atomSpec "osascript" <!>+  NotifyWithTerminalNotifier <$ atomSpec "terminal-notifier" <!>+  NotifyWithCustom . NonEmpty.toList <$> nonemptySpec stringSpec

src/Client/Configuration/ServerSettings.hs view

@@ -1,4 +1,4 @@-{-# LANGUAGE ApplicativeDo, TemplateHaskell, OverloadedStrings, RecordWildCards, BlockArguments #-}+{-# LANGUAGE LambdaCase, ApplicativeDo, TemplateHaskell, OverloadedStrings, RecordWildCards, BlockArguments #-}  {-| Module      : Client.Configuration.ServerSettings@@ -39,6 +39,8 @@   , ssConnectCmds   , ssSocksHost   , ssSocksPort+  , ssSocksUsername+  , ssSocksPassword   , ssChanservChannels   , ssFloodPenalty   , ssFloodThreshold@@ -55,6 +57,8 @@   , ssTlsCertFingerprint   , ssShowAccounts   , ssCapabilities+  , ssWindowHints+  , ssPalette    -- * SASL Mechanisms   , SaslMechanism(..)@@ -68,6 +72,9 @@   , SecretException(..)   , loadSecrets +  -- * Window Hints+  , WindowHint(..)+   -- * Defaults   , defaultServerSettings @@ -81,31 +88,42 @@   , getRegex   ) where -import           Client.Authentication.Scram (ScramDigest(..))-import           Client.Commands.Interpolation-import           Client.Commands.WordCompletion-import           Client.Configuration.Macros (macroCommandSpec)-import           Config.Schema.Spec-import           Control.Exception (Exception, displayException, throwIO, try)-import           Control.Lens-import           Control.Monad ((>=>))-import qualified Data.ByteString as B-import           Data.ByteString (ByteString)-import           Data.List.NonEmpty (NonEmpty((:|)))-import qualified Data.List.NonEmpty as NonEmpty-import           Data.List.Split (chunksOf, splitOn)-import           Data.Maybe (fromMaybe)-import           Data.Monoid-import           Data.Text (Text)-import qualified Data.Text as Text-import           Irc.Identifier (Identifier, mkId)-import           Network.Socket (HostName, PortNumber)-import           Numeric (readHex)-import qualified System.Exit as Exit-import qualified System.Process as Process-import           Text.Regex.TDFA-import           Text.Regex.TDFA.Text (compile)-import           Hookup (TlsVerify(..))+import Client.Authentication.Scram (ScramDigest(..))+import Client.Commands.Interpolation (ExpansionChunk)+import Client.Commands.WordCompletion+import Client.Configuration.Colors (attrSpec)+import Client.Configuration.Macros (macroCommandSpec)+import Client.Image.Palette (NetworkPalette (..), defaultNetworkPalette)+import Client.State.Focus ( Focus (NetworkFocus, ChannelFocus) )+import Client.State.Window (ActivityFilter (..))+import Config.Schema.Spec+import Control.Exception (Exception, displayException, throwIO, try)+import Control.Lens+import Control.Monad ((>=>))+import Data.ByteString (ByteString)+import Data.ByteString qualified as B+import Data.ByteString.Lazy qualified as L+import Data.Char (isLetter)+import qualified Data.HashMap.Strict as HashMap+import Data.List.NonEmpty (NonEmpty((:|)))+import Data.List.NonEmpty qualified as NonEmpty+import Data.List.Split (chunksOf, splitOn)+import Data.Map (Map)+import Data.Map qualified as Map+import Data.Maybe (fromMaybe)+import Data.Monoid (Endo(Endo))+import Data.Semigroup.Foldable (asum1)+import Data.Text (Text)+import Data.Text qualified as Text+import Data.Text.Encoding qualified as Text+import Hookup (TlsVerify(..))+import Irc.Identifier (Identifier, mkId)+import Network.Socket (HostName, PortNumber)+import Numeric (readHex)+import System.Exit qualified as Exit+import System.Process.Typed qualified as Process+import Text.Regex.TDFA (Regex, RegexOptions(defaultCompOpt), ExecOption(ExecOption, captureGroups))+import Text.Regex.TDFA.Text (compile)  -- | Static server-level settings data ServerSettings = ServerSettings@@ -130,6 +148,8 @@   , _ssConnectCmds      :: ![[ExpansionChunk]] -- ^ commands to execute upon successful connection   , _ssSocksHost        :: !(Maybe HostName) -- ^ hostname of SOCKS proxy   , _ssSocksPort        :: !PortNumber -- ^ port of SOCKS proxy+  , _ssSocksUsername    :: !(Maybe Text)+  , _ssSocksPassword    :: !(Maybe Secret)   , _ssChanservChannels :: ![Identifier] -- ^ Channels with chanserv permissions   , _ssFloodPenalty     :: !Rational -- ^ Flood limiter penalty (seconds)   , _ssFloodThreshold   :: !Rational -- ^ Flood limited threshold (seconds)@@ -143,6 +163,8 @@   , _ssBindHostName     :: Maybe HostName -- ^ Local bind host   , _ssShowAccounts     :: !Bool -- ^ Render account names   , _ssCapabilities     :: ![Text] -- ^ Extra capabilities to unconditionally request+  , _ssWindowHints      :: Map Focus WindowHint+  , _ssPalette          :: NetworkPalette   }   deriving Show @@ -163,6 +185,13 @@   | SaslEcdh     (Maybe Text) Text Secret -- ^ SASL ECDH-X25519-CHALLENGE - authzid authcid private-key   deriving Show +data WindowHint = WindowHint+  { windowHintName     :: Maybe Char+  , windowHintHideMeta :: Maybe Bool+  , windowHintHidden   :: Maybe Bool+  , windowHintActivity :: Maybe ActivityFilter+  } deriving Show+ -- | Regular expression matched with original source to help with debugging. data KnownRegex = KnownRegex Text Regex @@ -217,6 +246,8 @@        , _ssConnectCmds   = []        , _ssSocksHost     = Nothing        , _ssSocksPort     = 1080+       , _ssSocksUsername = Nothing+       , _ssSocksPassword = Nothing        , _ssChanservChannels = []        , _ssFloodPenalty     = 2 -- RFC 1459 defaults        , _ssFloodThreshold   = 10@@ -230,6 +261,8 @@        , _ssBindHostName     = Nothing        , _ssShowAccounts     = False        , _ssCapabilities     = []+       , _ssWindowHints      = Map.empty+       , _ssPalette          = defaultNetworkPalette        }  serverSpec :: ValueSpec (Maybe Text, ServerSettings -> ServerSettings)@@ -307,6 +340,12 @@       , req "socks-port" ssSocksPort numSpec         "Port number of SOCKS5 proxy server" +      , opt "socks-username" ssSocksUsername textSpec+        "Username of SOCKS5 proxy server"++      , opt "socks-password" ssSocksPassword anySpec+        "Password of SOCKS5 proxy server"+       , req "connect-cmds" ssConnectCmds (listSpec macroCommandSpec)         "Command to be run upon successful connection to server" @@ -354,14 +393,48 @@        , req "capabilities" ssCapabilities anySpec         "Extra capabilities to unconditionally request from the server"++      , req "window-hints" ssWindowHints windowHintsSpec+        "Persistent settings for windows"+      +      , req "palette" ssPalette netPaletteSpec+        "Network-specific palette overrides"       ] +windowHintsSpec :: ValueSpec (Map Focus WindowHint)+windowHintsSpec = Map.fromList <$> listSpec entrySpec+  where+    entrySpec =+      sectionsSpec "window-hint"+        do focus              <- reqSection' "window"    focusSpec   "channel name or network"+           windowHintName     <- optSection' "hotkey"    hotkeySpec  "reserved hotkey"+           windowHintHidden   <- optSection' "hidden"    yesOrNoSpec "hide from statusbar"+           windowHintHideMeta <- optSection' "hide-meta" yesOrNoSpec "hide metadata by default"+           windowHintActivity <- optSection' "activity"  activitySpec "activity indicators"+           pure (focus, WindowHint{..})++    focusSpec =+      NetworkFocus "" <$ atomSpec "network" <!>+      ChannelFocus "" . mkId <$> textSpec++    hotkeySpec =+      '\0' <$ atomSpec "none" <!>+      customSpec "single letter" stringSpec \case+        [x] -> Right x+        _   -> Left "expected a single letter"+ tlsModeSpec :: ValueSpec TlsMode tlsModeSpec =   TlsYes   <$ atomSpec "yes"      <!>   TlsNo    <$ atomSpec "no"       <!>   TlsStart <$ atomSpec "starttls" +-- TODO: May be nice to be able to do this for all Show Enums.+activitySpec :: ValueSpec ActivityFilter+activitySpec = asum1 (NonEmpty.fromList (map mkSpec [(toEnum 0)..]))+  where+    mkSpec a = a <$ atomSpec (Text.pack (show a))+ tlsVerifySpec :: ValueSpec TlsVerify tlsVerifySpec =   VerifyDefault  <$ atomSpec "yes"      <!>@@ -411,8 +484,6 @@       authzid <*> username <*> reqSection "private-key" "Private Key"  -- filepathSpec :: ValueSpec FilePath filepathSpec = customSpec "path" stringSpec $ \str ->   if null str@@ -487,8 +558,9 @@     Right r -> Right (KnownRegex str r)  instance HasSpec Secret where-  anySpec = SecretText <$> textSpec <!>-            SecretCommand <$> sectionsSpec "command" (reqSection "command" "Command and arguments to execute to secret")+  anySpec =+    SecretText <$> textSpec <!>+    SecretCommand <$> sectionsSpec "command" (reqSection "command" "Command and arguments to execute to secret")  data SecretException = SecretException String String   deriving Show@@ -499,19 +571,47 @@ -- Throws 'SecretException' loadSecrets :: ServerSettings -> IO ServerSettings loadSecrets =-  traverseOf (ssPassword             . _Just                  ) (loadSecret "server password") >=>-  traverseOf (ssSaslMechanism        . _Just . _SaslPlain . _3) (loadSecret "SASL password") >=>-  traverseOf (ssTlsClientKeyPassword . _Just                  ) (loadSecret "TLS key password") >=>-  traverseOf (ssSaslMechanism        . _Just . _SaslScram . _4) (loadSecret "SASL password") >=>-  traverseOf (ssSaslMechanism        . _Just . _SaslEcdh  . _3) (loadSecret "SASL private key")+  traverseOf (ssPassword             . _Just) (loadSecret "server password") >=>+  traverseOf (ssSocksPassword        . _Just) (loadSecret "socks password") >=>+  traverseOf (ssTlsClientKeyPassword . _Just) (loadSecret "TLS key password") >=>+  traverseOf (ssSaslMechanism        . _Just) loadSaslSecret +-- | Populate secrets from sasl mechanism+loadSaslSecret :: SaslMechanism -> IO SaslMechanism+loadSaslSecret =+  traverseOf (_SaslPlain . _3) (loadSecret "SASL plain password") >=>+  traverseOf (_SaslScram . _4) (loadSecret "SASL scram password") >=>+  traverseOf (_SaslEcdh  . _3) (loadSecret "SASL ecdh private key")+ -- | Run a command if found and replace it with the first line of stdout result. loadSecret :: String -> Secret -> IO Secret loadSecret _ (SecretText txt) = pure (SecretText txt) loadSecret label (SecretCommand (cmd NonEmpty.:| args)) =   do let u = Text.unpack-     res <- try (Process.readProcessWithExitCode (u cmd) (map u args) "")+     res <- try (Process.readProcess (Process.proc (u cmd) (map u args)))      case res of-       Right (Exit.ExitSuccess,out,_) -> pure (SecretText (Text.pack (takeWhile ('\n' /=) out)))-       Right (Exit.ExitFailure{},_,err) -> throwIO (SecretException label err)+       Right (Exit.ExitSuccess,out,_) ->+         case Text.decodeUtf8' (L.toStrict out) of+             Right str -> pure (SecretText (Text.takeWhile ('\n' /=) str))+             Left e -> throwIO (SecretException label (displayException e))+       Right (Exit.ExitFailure{},_,err) ->+         case Text.decodeUtf8' (L.toStrict err) of+             Right str -> throwIO (SecretException label (Text.unpack str))+             Left e -> throwIO (SecretException label (displayException e))        Left ioe -> throwIO (SecretException label (displayException (ioe::IOError)))+++netPaletteSpec :: ValueSpec NetworkPalette+netPaletteSpec = +  sectionsSpec "palette-net" $+  do _palCModes <- fromMaybe HashMap.empty <$> optSection' "cmodes" colorMapSpec+                   "Overrides for the styles used for specific channel mode letters."+     _palUModes <- fromMaybe HashMap.empty <$> optSection' "umodes" colorMapSpec+                   "Overrides for the styles used for specific user mode letters."+     _palSnomask <- fromMaybe HashMap.empty <$> optSection' "snomask" colorMapSpec+                    "Overrides for the styles used for specific snomask letters."+     pure NetworkPalette{..}+  where+    colorMapSpec = HashMap.fromList . concatMap expand <$> assocSpec attrSpec+      where+        expand (modes, style) = [(mode, style) | mode <- Text.unpack modes, isLetter mode]

src/Client/Configuration/Sts.hs view

@@ -19,21 +19,22 @@   , savePolicyFile   ) where -import           Config (Value(..), Section(..), parse, pretty)-import           Config.Number (integerToNumber)-import           Config.Schema.Spec-import           Config.Schema.Load (loadValue)-import           Control.Exception (try)-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 ((</>), takeDirectory)-import           Data.HashMap.Strict (HashMap)-import qualified Data.HashMap.Strict as HashMap+import Config (Value(..), Section(..), parse, pretty)+import Config.Number (integerToNumber)+import Config.Schema.Load (loadValue)+import Config.Schema.Spec+import Control.Exception (try)+import Control.Lens (makeLenses)+import Data.HashMap.Strict (HashMap)+import Data.HashMap.Strict qualified as HashMap+import Data.Maybe (fromMaybe)+import Data.Text (Text)+import Data.Text qualified as Text+import Data.Text.IO qualified as Text+import Data.Time (UTCTime)+import Data.Time.Format.ISO8601 (formatParseM, formatShow, ISO8601(iso8601Format))+import System.Directory (getXdgDirectory, XdgDirectory(XdgConfig), createDirectoryIfMissing)+import System.FilePath ((</>), takeDirectory)  data StsPolicy = StsPolicy   { _stsExpiration :: !UTCTime@@ -68,7 +69,7 @@           Section () "until"             (Text ()                (Text.pack-                 (formatTime defaultTimeLocale dateTimeFormat+                 (formatShow iso8601Format                    (_stsExpiration v))))         ]     | (k, v) <- HashMap.toList p ]@@ -106,7 +107,4 @@ dateTimeSpec   = customSpec "date-time" stringSpec   $ maybe (Left "unable to parse") Right-  . parseTimeM False defaultTimeLocale dateTimeFormat--dateTimeFormat :: String-dateTimeFormat = iso8601DateFormat (Just "%H:%M:%S")+  . formatParseM iso8601Format

src/Client/EventLoop.hs view

@@ -1,4 +1,4 @@-{-# Language BangPatterns, OverloadedStrings, NondecreasingIndentation #-}+{-# Language BangPatterns, OverloadedStrings, NondecreasingIndentation, PatternSynonyms #-}  {-| Module      : Client.EventLoop@@ -17,51 +17,53 @@   , ClientEvent(..)   ) where -import           Client.CApi (ThreadEntry, popTimer)-import           Client.Commands-import           Client.Configuration (configJumpModifier, configKeyMap, configWindowNames, configDigraphs)-import           Client.Configuration.ServerSettings-import           Client.EventLoop.Actions-import           Client.EventLoop.Errors (exceptionToLines)-import           Client.EventLoop.Network (clientResponse)-import           Client.Hook-import           Client.Image-import           Client.Image.Layout (scrollAmount)-import           Client.Image.StatusLine (clientTitle)-import           Client.Log-import           Client.Message-import           Client.Network.Async-import           Client.State-import qualified Client.State.EditBox as Edit-import           Client.State.Extensions-import           Client.State.Focus-import           Client.State.Network-import           Control.Concurrent.STM-import           Control.Exception-import           Control.Lens-import           Control.Monad-import           Data.ByteString (ByteString)-import           Data.Char (isSpace)-import           Data.Foldable-import           Data.Traversable-import           Data.List-import           Data.List.NonEmpty (NonEmpty, nonEmpty)-import           Data.Maybe-import           Data.Ord-import           Data.Text (Text)-import qualified Data.HashMap.Strict as HashMap-import qualified Data.Text as Text-import qualified Data.Text.Encoding as Text-import qualified Data.Text.Encoding.Error as Text-import           Data.Time-import           GHC.IO.Exception (IOErrorType(..), ioe_type)-import           Graphics.Vty-import           Graphics.Vty.Input.Events-import           Irc.Message-import           Irc.Codes-import           Irc.RawIrcMsg-import           LensUtils-import           Hookup (ConnectionFailure(..))+import Client.CApi (ThreadEntry, popTimer)+import Client.Commands (CommandResult(..), execute, executeUserCommand, tabCompletion)+import Client.Configuration (configJumpModifier, configKeyMap, configWindowNames, configDigraphs, configNotifications)+import Client.Configuration.Notifications (notifyCmd)+import Client.Configuration.ServerSettings ( ssReconnectAttempts )+import Client.EventLoop.Actions (keyToAction, Action(..))+import Client.EventLoop.Errors (exceptionToLines)+import Client.EventLoop.Network (clientResponse)+import Client.Hook (applyMessageHooks, messageHookStateful)+import Client.Image (clientPicture)+import Client.Image.Layout (scrollAmount)+import Client.Image.StatusLine (clientTitle)+import Client.Log ( writeLogLine )+import Client.Message+import Client.Network.Async+import Client.State+import Client.State.EditBox qualified as Edit+import Client.State.Extensions+import Client.State.Focus (Subfocus(FocusMessages))+import Client.State.Network+import Control.Concurrent.STM+import Control.Exception (SomeException, Exception(fromException), catch)+import Control.Lens+import Control.Monad (when, MonadPlus(mplus), foldM, unless, void)+import Data.ByteString (ByteString)+import Data.Char (isSpace)+import Data.Foldable (Foldable(foldl'), find, asum, traverse_)+import Data.HashMap.Strict qualified as HashMap+import Data.List (partition)+import Data.List.NonEmpty (NonEmpty, nonEmpty)+import Data.Maybe (fromMaybe)+import Data.Ord (comparing)+import Data.Text (Text)+import Data.Text qualified as Text+import Data.Text.Encoding qualified as Text+import Data.Text.Encoding.Error qualified as Text+import Data.Time+import Data.Time.Format.ISO8601 (formatParseM, iso8601Format)+import Data.Traversable (for)+import GHC.IO.Exception (IOErrorType(..), ioe_type)+import Graphics.Vty+import Hookup (ConnectionFailure(..))+import Irc.Codes (pattern RPL_STARTTLS)+import Irc.Message (IrcMsg(Reply, Notice), cookIrcMsg, msgTarget)+import Irc.RawIrcMsg (RawIrcMsg, TagEntry(..), asUtf8, msgTags, parseRawIrcMsg)+import LensUtils (setStrict)+import System.Process.Typed (startProcess, setStdin, setStdout, setStderr, nullStream)   -- | Sum of the five possible event types the event loop handles@@ -83,7 +85,7 @@   do timer <- prepareTimer      atomically (asum [timer, vtyEvent, networkEvents, threadJoin])   where-    vtyEvent = VtyEvent <$> readTChan (_eventChannel (inputIface vty))+    vtyEvent = VtyEvent <$> readTChan (eventChannel (inputIface vty))      networkEvents =       do xs <- for (HashMap.toList (view clientConnections st)) $ \(network, conn) ->@@ -135,6 +137,7 @@ eventLoop :: Vty -> ClientState -> IO () eventLoop vty st =   do when (view clientBell st) (beep vty)+     processNotifications st      processLogEntries st       let (pic, st') = clientPicture (clientTick st)@@ -151,7 +154,7 @@          eventLoop vty =<< doTimerEvent networkId action st'        VtyEvent (InputEvent vtyEvent) ->          traverse_ (eventLoop vty) =<< doVtyEvent vty vtyEvent st'-       VtyEvent ResumeAfterSignal ->+       VtyEvent ResumeAfterInterrupt ->          eventLoop vty =<< updateTerminalSize vty st        NetworkEvents networkEvents ->          eventLoop vty =<< foldM doNetworkEvent st' networkEvents@@ -175,6 +178,20 @@ processLogEntries =   traverse_ writeLogLine . reverse . view clientLogQueue +processNotifications :: ClientState -> IO ()+processNotifications st =+  case notifyCmd (view (clientConfig . configNotifications) st) of+    Just cmd | not (view clientUiFocused st) -> traverse_ (spawn cmd) (view clientNotifications st)+    _ -> return ()+  where+    -- TODO: May be a nicer way to handle notification failure than just silently squashing the exception+    handleException :: SomeException -> IO ()+    handleException _ = return ()+    spawn cmd pair = do+      let procCfg = setStdin nullStream . setStdout nullStream . setStderr nullStream $ cmd pair+      -- Maybe find a nicer way to get an error out of here.+      catch (void (startProcess procCfg)) handleException+ -- | Respond to a network connection successfully connecting. doNetworkOpen ::   Text        {- ^ network name -} ->@@ -370,8 +387,7 @@  -- | Parses the time format used by ZNC for buffer playback parseZncTime :: String -> Maybe UTCTime-parseZncTime = parseTimeM True defaultTimeLocale-             $ iso8601DateFormat (Just "%T%Q%Z")+parseZncTime = formatParseM iso8601Format   -- | Update the height and width fields of the client state@@ -401,6 +417,10 @@     EvPaste utf8 ->        do let str = Text.unpack (Text.decodeUtf8With Text.lenientDecode utf8)           return $! Just $! over clientTextBox (Edit.insertPaste str) st+    EvLostFocus ->+      return (Just $! set clientUiFocused False st)+    EvGainedFocus ->+      return (Just $! set clientUiFocused True st)     _ -> return (Just st)

src/Client/EventLoop/Actions.hs view

@@ -23,20 +23,20 @@   , actionName   ) where -import           Graphics.Vty.Input.Events-import           Config.Schema.Spec-import           Control.Applicative-import           Control.Lens-import           Data.Char (showLitChar)-import           Data.Functor.Compose-import           Data.List-import           Data.Map (Map)-import qualified Data.Map as Map-import           Data.HashMap.Lazy (HashMap)-import qualified Data.HashMap.Lazy as HashMap-import           Data.Text (Text)-import qualified Data.Text as Text-import           Text.Read+import Config.Schema.Spec (anyAtomSpec, customSpec, HasSpec(..))+import Control.Applicative (Alternative(empty))+import Control.Lens (Lens', (^.), non', (?~), set, At(at), AsEmpty(_Empty))+import Data.Char (showLitChar)+import Data.Functor.Compose (Compose(Compose, getCompose))+import Data.HashMap.Lazy (HashMap)+import Data.HashMap.Lazy qualified as HashMap+import Data.List (nub, sort)+import Data.Map (Map)+import Data.Map qualified as Map+import Data.Text (Text)+import Data.Text qualified as Text+import Graphics.Vty.Input.Events+import Text.Read (readMaybe)  -- | Actions that can be invoked using the keyboard. data Action

src/Client/EventLoop/Errors.hs view

@@ -14,10 +14,10 @@   ( exceptionToLines   ) where -import           Control.Exception-import           Data.List.NonEmpty (NonEmpty(..))-import           OpenSSL.Session-import           Hookup (ConnectionFailure(..))+import Control.Exception (SomeException, Exception(displayException, fromException))+import Data.List.NonEmpty (NonEmpty(..))+import OpenSSL.Session (ConnectionAbruptlyTerminated, ProtocolError(ProtocolError))+import Hookup (ConnectionFailure(..))  -- | Compute the message message text to be used for a connection error exceptionToLines ::

src/Client/EventLoop/Network.hs view

@@ -1,4 +1,4 @@-{-# Language OverloadedStrings #-}+{-# Language OverloadedStrings, PatternSynonyms #-} {-| Module      : Client.EventLoop.Network Description : Event handlers for network messages affecting the client state@@ -13,27 +13,27 @@   ( clientResponse   ) where -import           Client.Commands-import           Client.Commands.Interpolation-import           Client.Configuration.ServerSettings-import           Client.Configuration.Sts-import           Client.Network.Async-import           Client.Network.Connect-import           Client.State-import           Client.State.Focus-import           Client.State.Network-import           Control.Lens-import           Control.Monad-import           Data.Text (Text)-import           Data.Time-import           Irc.Codes-import           Irc.Commands-import           Irc.Identifier-import           Irc.Message-import qualified Client.Authentication.Ecdsa as Ecdsa-import qualified Data.Text as Text-import qualified Data.Text.Read as Text-import           Text.Regex.TDFA.Text as Regex+import Client.Authentication.Ecdsa qualified as Ecdsa+import Client.Commands (CommandResult(CommandQuit, CommandFailure, CommandSuccess), commandExpansion, executeUserCommand)+import Client.Commands.Interpolation (resolveMacroExpansions, ExpansionChunk)+import Client.Configuration.ServerSettings+import Client.Configuration.Sts (savePolicyFile, StsPolicy(StsPolicy, _stsPort, _stsExpiration))+import Client.Network.Async (abortConnection, TerminationReason(StsUpgrade))+import Client.Network.Connect (ircPort)+import Client.State+import Client.State.Focus (Focus(ChannelFocus, NetworkFocus))+import Client.State.Network+import Control.Lens (view, (&), folded, previews, views, (?~), set, At(at))+import Control.Monad (join, foldM, forM)+import Data.Text (Text)+import Data.Text qualified as Text+import Data.Text.Read qualified as Text+import Data.Time (ZonedTime, addUTCTime, getCurrentTime, formatTime, defaultTimeLocale, utcToLocalZonedTime)+import Irc.Codes (pattern ERR_LINKCHANNEL, pattern RPL_WELCOME)+import Irc.Commands (ircAuthenticate, ircCapEnd)+import Irc.Identifier (mkId)+import Irc.Message (IrcMsg(Error, Reply, Authenticate, Cap), CapCmd(CapNew, CapLs))+import Text.Regex.TDFA.Text qualified as Regex  -- | Client-level responses to specific IRC messages. -- This is in contrast to the connection state tracking logic in

src/Client/Hook.hs view

@@ -22,10 +22,9 @@   , applyMessageHooks   ) where -import Control.Lens-import Data.Text--import Irc.Message+import Control.Lens (view, makeLenses)+import Data.Text (Text)+import Irc.Message (IrcMsg)  -- | The possible results of a 'MessageHook' action. A hook can decline to -- handle a message ('PassMessage'), filter out a message ('OmitMessage'),

src/Client/Hook/DroneBLRelay.hs view

@@ -15,19 +15,17 @@   ( droneblRelayHook   ) where -import           Data.List (uncons)-import qualified Data.Text as Text-import           Data.Text (Text)-import           Data.Foldable (asum)--import           Text.Regex.TDFA (match, defaultCompOpt, defaultExecOpt, Regex)-import           Text.Regex.TDFA.String (compile)--import           Client.Hook (MessageHook(..), MessageResult(..))-import           Irc.Message-import           Irc.Identifier (mkId, Identifier)-import           Irc.UserInfo (UserInfo(..))-import           StrQuote (str)+import Client.Hook (MessageHook(..), MessageResult(..))+import Data.Foldable (asum)+import Data.List (uncons)+import Data.Text (Text)+import Data.Text qualified as Text+import Irc.Identifier (mkId, Identifier)+import Irc.Message (IrcMsg(Mode, Privmsg, Ctcp, Join, Part, Quit, Nick, Kick), Source(Source))+import Irc.UserInfo (UserInfo(..))+import StrQuote (str)+import Text.Regex.TDFA (match, defaultCompOpt, defaultExecOpt, Regex)+import Text.Regex.TDFA.String (compile)  -- | Hook for mapping messages in #dronebl -- to appear like native messages.

src/Client/Hook/Matterbridge.hs view

@@ -25,16 +25,13 @@ -} module Client.Hook.Matterbridge (matterbridgeHook) where -import Data.Text (Text)--import Control.Lens (set, view)--import Text.Regex.TDFA ((=~))- import Client.Hook (MessageHook(..), MessageResult(..))-import Irc.Message+import Control.Lens (set, view)+import Data.Text (Text) import Irc.Identifier (mkId, Identifier)+import Irc.Message (IrcMsg(Ctcp, Privmsg), Source(Source)) import Irc.UserInfo (UserInfo(..), uiNick)+import Text.Regex.TDFA ((=~))  data MbMsg = Msg | Act @@ -57,9 +54,9 @@  remap' :: MbMsg -> UserInfo -> Identifier -> Text -> MessageResult remap' mbmsg ui chan msg =-  case msg =~ ("^<([^>]+)> (.*)$"::Text) of-    [_,nick,msg']:_ -> RemapMessage (newmsg mbmsg (fakeUser nick ui) chan msg')-    _               -> PassMessage+  case msg =~ ("^(\x03\&[0-9]{2})?<([^>]+)> \x0f?(.*)$"::Text) of+    [_,_,nick,msg']:_ -> RemapMessage (newmsg mbmsg (fakeUser nick ui) chan msg')+    _                 -> PassMessage  newmsg :: MbMsg -> Source -> Identifier -> Text -> IrcMsg newmsg Msg src chan msg = Privmsg src chan msg

src/Client/Hook/Snotice.hs view

@@ -13,17 +13,16 @@   ( 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           StrQuote (str)+import Client.Hook (MessageHook(MessageHook), MessageResult(..))+import Data.List (find)+import Data.Text (Text)+import Data.Text qualified as Text+import Irc.Identifier (mkId, Identifier)+import Irc.Message (IrcMsg(Notice), Source(Source))+import Irc.UserInfo (UserInfo(UserInfo))+import StrQuote (str)+import Text.Regex.TDFA+import Text.Regex.TDFA.String (compile)  snoticeHook :: MessageHook snoticeHook = MessageHook "snotice" True remap@@ -98,6 +97,7 @@     (2, "k", [str|^[^ ]+ added temporary [0-9]+ min. K-Line for |]),     -- Nick collision     (1, "m", [str|^Nick collision on|]),+    (1, "m", [str|^Nick collision due to services forced nick change on|]),     -- KILLs     (0, "k", [str|^Received KILL message for [^ ]+\. From NickServ |]),     (0, "k", [str|^Received KILL message for [^ ]+\. From syn Path: [^ ]+ \(Facility Blocked\)|]),@@ -114,8 +114,8 @@     (1, "f", [str|^Failed (OPER|CHALLENGE) attempt - host mismatch|]),     (3, "f", [str|^Failed (OPER|CHALLENGE) attempt|]), -- ORDER IMPORTANT - catch all failed attempts that aren't host mismatch -    (1, "k", [str|^Rejecting [XK]-Lined user|]),-    (1, "k", [str|^Disconnecting [XK]-Lined user|]),+    (1, "k", [str|^Rejecting [DKX]-Lined user|]),+    (1, "k", [str|^Disconnecting [DKX]-Lined user|]),     (1, "k", [str|^KLINE active for|]),     (1, "k", [str|^XLINE active for|]),     (3, "k", [str|^KLINE over-ruled for |]),@@ -127,6 +127,7 @@     (2, "k", [str|^[^ ]+![^ ]+@[^ ]+\{[^ ]+\} has removed the X-Line for:|]),     (2, "k", [str|^[^ ]+![^ ]+@[^ ]+\{[^ ]+\} is removing the X-Line for|]),     (2, "k", [str|^[^ ]+![^ ]+@[^ ]+\{[^ ]+\} has removed the temporary D-Line for:|]),+    (2, "k", [str|^User [^ ]+ \([^ ]+@[^ ]+\) is attempting to join locally juped channel [^ ]+ \(.*\)$|]),      (0, "m", [str|^Received SAVE message for|]),     (0, "m", [str|^Ignored noop SAVE message for|]),

src/Client/Hook/Znc/Buffextras.hs view

@@ -17,14 +17,13 @@   ( buffextrasHook   ) where -import           Data.Attoparsec.Text as P-import           Data.Text as Text hiding (head)--import           Client.Hook-import           Irc.Identifier-import           Irc.Message-import           Irc.RawIrcMsg-import           Irc.UserInfo+import Client.Hook (MessageHook(MessageHook), MessageResult(..))+import Data.Attoparsec.Text as P+import Data.Text as Text (Text, null, words)+import Irc.Identifier (Identifier, mkId)+import Irc.Message (IrcMsg(Topic, Privmsg, Join, Quit, Part, Nick, Mode, Kick), Source(Source, srcUser))+import Irc.RawIrcMsg (prefixParser, simpleTokenParser)+import Irc.UserInfo (UserInfo(userNick))  -- | Map ZNC's buffextras messages to native client messages. -- Set debugging to pass through buffextras messages that

src/Client/Hooks.hs view

@@ -15,14 +15,14 @@   ( messageHooks   ) where -import Data.Text-import Data.HashMap.Strict-import Client.Hook+import Client.Hook (MessageHook)+import Data.HashMap.Strict (HashMap, fromList)+import Data.Text (Text) -import Client.Hook.DroneBLRelay-import Client.Hook.Matterbridge-import Client.Hook.Snotice-import Client.Hook.Znc.Buffextras+import Client.Hook.DroneBLRelay (droneblRelayHook)+import Client.Hook.Matterbridge (matterbridgeHook)+import Client.Hook.Snotice (snoticeHook)+import Client.Hook.Znc.Buffextras (buffextrasHook)  -- | All the available message hooks. messageHooks :: HashMap Text ([Text] -> Maybe MessageHook)

src/Client/Image.hs view

@@ -11,12 +11,11 @@ -} module Client.Image (clientPicture) where -import           Client.Image.Layout-import           Client.State-import           Control.Lens-import           Graphics.Vty            (Background (..), Cursor (..),-                                          Picture (..))-import           Graphics.Vty.Image+import Client.Image.Layout (drawLayout)+import Client.State (clientHeight, clientScroll, clientTextBoxOffset, ClientState)+import Control.Lens (view, over, set)+import Graphics.Vty (Background (..), Cursor (..),  Picture (..))+import Graphics.Vty.Image (Image)  -- | Generate a 'Picture' for the current client state. The resulting -- client state is updated for render specific information like scrolling.

src/Client/Image/Layout.hs view

@@ -8,18 +8,18 @@ -} module Client.Image.Layout (scrollAmount, drawLayout) where -import Control.Lens-import Client.State-import Client.State.Focus import Client.Configuration (LayoutMode(..))+import Client.Image.LineWrap (lineWrap, terminate) import Client.Image.PackedImage (Image', unpackImage)+import Client.Image.Palette (palWindowDivider) import Client.Image.StatusLine (statusLineImage, minorStatusLineImage)-import Client.Image.Textbox-import Client.Image.LineWrap (lineWrap, terminate)-import Client.Image.Palette-import Client.View-import Graphics.Vty.Image+import Client.Image.Textbox (textboxImage)+import Client.State+import Client.State.Focus ( Focus, Subfocus )+import Client.View (viewLines)+import Control.Lens (view) import Graphics.Vty.Attributes (defAttr)+import Graphics.Vty.Image  -- | Compute the combined image for all the visible message windows. drawLayout ::

src/Client/Image/LineWrap.hs view

@@ -15,10 +15,10 @@   , terminate   ) where -import           Client.Image.PackedImage-import qualified Graphics.Vty.Image as Vty-import           Graphics.Vty.Attributes-import qualified Data.Text.Lazy as L+import Client.Image.PackedImage (char, imageText, imageWidth, splitImage, string, Image')+import Graphics.Vty.Image qualified as Vty+import Graphics.Vty.Attributes (defAttr)+import Data.Text.Lazy qualified as L   -- | Trailing space with default attributes deals with bug in VTY

src/Client/Image/Message.hs view

@@ -25,37 +25,39 @@   , nickPad   , timeImage   , drawWindowLine-+  , modesImage+  , prettyTime   , parseIrcTextWithNicks   , Highlight(..)   ) where -import           Client.Configuration (PaddingMode(..))-import           Client.Image.LineWrap-import           Client.Image.MircFormatting-import           Client.Image.PackedImage-import           Client.Image.Palette-import           Client.Message-import           Client.State.Window-import           Client.UserHost-import           Control.Applicative ((<|>))-import           Control.Lens-import           Data.Char-import           Data.Hashable (hash)-import           Data.HashMap.Strict (HashMap)-import qualified Data.HashMap.Strict as HashMap-import           Data.List-import           Data.Text (Text)-import qualified Data.Text as Text-import           Data.Time-import qualified Data.Vector as Vector-import           Graphics.Vty.Attributes-import           Irc.Codes-import           Irc.Identifier-import           Irc.Message-import           Irc.RawIrcMsg-import           Irc.UserInfo-import           Text.Read+import Client.Configuration (PaddingMode(..))+import Client.Image.LineWrap (lineWrapPrefix)+import Client.Image.MircFormatting (parseIrcText, parseIrcText')+import Client.Image.PackedImage (char, imageWidth, string, text', Image')+import Client.Image.Palette+import Client.Message+import Client.State.Window (unpackTimeOfDay, wlImage, wlPrefix, wlTimestamp, WindowLine)+import Client.UserHost ( uhAccount, UserAndHost )+import Control.Applicative ((<|>))+import Control.Lens (view, (^?), filtered, folded, views, Ixed(ix), At (at))+import Data.Char (ord, chr, isControl)+import Data.Hashable (hash)+import Data.HashMap.Strict (HashMap)+import Data.HashMap.Strict qualified as HashMap+import Data.List (intercalate, intersperse)+import Data.Maybe (fromMaybe)+import Data.Text (Text)+import Data.Text qualified as Text+import Data.Time (UTCTime, ZonedTime, TimeOfDay, formatTime, defaultTimeLocale, parseTimeM)+import Data.Vector qualified as Vector+import Graphics.Vty.Attributes+import Irc.Codes+import Irc.Identifier (Identifier, idText, mkId)+import Irc.Message+import Irc.RawIrcMsg (msgCommand, msgParams, msgPrefix)+import Irc.UserInfo (UserInfo(userHost, userNick, userName))+import Text.Read (readMaybe)  -- | Parameters used when rendering messages data MessageRendererParams = MessageRendererParams@@ -64,6 +66,8 @@   , rendHighlights :: HashMap Identifier Highlight -- ^ words to highlight   , rendPalette    :: Palette -- ^ nick color palette   , rendAccounts   :: Maybe (HashMap Identifier UserAndHost)+  , rendNetPalette :: NetworkPalette+  , rendChanTypes  :: [Char] -- ^ A list of valid channel name prefixes.   }  -- | Default 'MessageRendererParams' with no sigils or nicknames specified@@ -74,9 +78,10 @@   , rendHighlights  = HashMap.empty   , rendPalette     = defaultPalette   , rendAccounts    = Nothing+  , rendNetPalette  = defaultNetworkPalette+  , rendChanTypes   = "#&!+" -- Default for if we aren't told otherwise by ISUPPORT.   } - -- | Construct a message given the time the message was received and its -- render parameters. msgImage ::@@ -239,6 +244,7 @@     Ping       {} -> mempty     Pong       {} -> mempty     Nick       {} -> mempty+    Away       {} -> mempty      -- details in message part     Topic src _ _  -> who src@@ -301,6 +307,7 @@     BatchEnd    {} -> mempty     Nick        {} -> mempty     Authenticate{} -> "***"+    Away        {} -> mempty      Error                   txt -> parseIrcText pal txt     Topic _ _ txt ->@@ -334,10 +341,15 @@       separatedParams pal (view msgParams irc)     Cap cmd           -> ctxt (capCmdText cmd) -    Mode _ _ params ->+    Mode _ chan (modes:params) ->       "set mode: " <>+      modesImage (view palModes pal) (modesPaletteFor chan rp) (Text.unpack modes) <>+      " " <>       ircWords pal params +    Mode _ _ [] ->+      "changed no modes"+     Invite _ tgt chan ->       "invited " <>       coloredIdentifier pal NormalIdentifier hilites tgt <>@@ -375,13 +387,13 @@   in   case body of     Nick old new ->-      string quietAttr "nick " <>+      string (view palUsrChg pal) "nick " <>       who old <>       " is now known as " <>       coloredIdentifier pal NormalIdentifier hilites new      Join nick _chan acct gecos ->-      string quietAttr "join " <>+      string (view palJoin pal) "join " <>       plainWho (srcUser nick) <>       accountPart <> gecosPart       where@@ -394,21 +406,21 @@           | otherwise       = text' quietAttr (" [" <> cleanText gecos <> "]")      Part nick _chan mbreason ->-      string quietAttr "part " <>+      string (view palPart pal) "part " <>       who nick <>       foldMap (\reason -> string quietAttr " (" <>                           parseIrcText pal reason <>                           string quietAttr ")") mbreason      Quit nick mbreason ->-      string quietAttr "quit "   <>+      string (view palPart pal) "quit "   <>       who nick <>       foldMap (\reason -> string quietAttr " (" <>                           parseIrcText pal reason <>                           string quietAttr ")") mbreason      Kick kicker _channel kickee reason ->-      string quietAttr "kick " <>+      string (view palPart pal) "kick " <>       who kicker <>       " kicked " <>       coloredIdentifier pal NormalIdentifier hilites kickee <>@@ -416,7 +428,7 @@       parseIrcText pal reason      Kill killer killee reason ->-      string quietAttr "kill " <>+      string (view palPart pal) "kill " <>       who killer <>       " killed " <>       coloredIdentifier pal NormalIdentifier hilites killee <>@@ -498,26 +510,41 @@       ": " <>       ctxt (capCmdText cmd) -    Mode nick _chan params ->-      string quietAttr "mode " <>+    Mode nick chan (modes:params) ->+      string (view palModes pal) "mode " <>       who nick <> " set mode: " <>+      modesImage (view palModes pal) (modesPaletteFor chan rp) (Text.unpack modes) <>+      " " <>       ircWords pal params +    Mode nick _ [] ->+      string (view palModes pal) "mode " <>+      who nick <> " changed no modes"+     Authenticate{} -> "AUTHENTICATE ***"     BatchStart{}   -> "BATCH +"     BatchEnd{}     -> "BATCH -"      Account src acct ->-      string quietAttr "acct " <>+      string (view palUsrChg pal) "acct " <>       who src <> ": " <>       if Text.null acct then "*" else ctxt acct      Chghost user newuser newhost ->-      string quietAttr "chng " <>+      string (view palUsrChg pal) "chng " <>       who user <> ": " <>       ctxt newuser <> " " <> ctxt newhost +    Away user (Just txt) ->+      string (view palAway pal) "away " <>+      who user <> ": " <>+      parseIrcTextWithNicks pal hilites False txt +    Away user Nothing ->+      string (view palUsrChg pal) "back " <>+      who user++ renderCapCmd :: CapCmd -> Text renderCapCmd cmd =   case cmd of@@ -616,7 +643,6 @@         RPL_ETRACEFULL   -> etraceFullParamsImage         RPL_ENDOFTRACE   -> params_2_3_Image         RPL_ENDOFHELP    -> params_2_3_Image-        RPL_LIST         -> listParamsImage         RPL_LINKS        -> linksParamsImage         RPL_ENDOFLINKS   -> params_2_3_Image         RPL_PRIVS        -> privsImage@@ -881,12 +907,6 @@         [_, nick, txt] -> ctxt nick <> label " msg" <> parseIrcText pal txt         _ -> rawParamsImage -    listParamsImage =-      case params of-        [_, chan, users, topic] ->-          ctxt chan <> label " users" <> ctxt users <> label " topic" <> ctxt topic-        _ -> rawParamsImage-     linksParamsImage =       case params of         [_, name, link, Text.breakOn " " -> (hops,location)] ->@@ -1108,7 +1128,7 @@             PrivmsgIdentifier -> view palSelfHighlight palette             NormalIdentifier  -> view palSelf palette -      | otherwise = v Vector.! i+      | otherwise = fromMaybe (v Vector.! i) (HashMap.lookup ident (view palIdOverride palette))      v = view palNicks palette     i = hash ident `mod` Vector.length v@@ -1182,24 +1202,29 @@  -- | Returns image and identifier to be used when collapsing metadata -- messages.-metadataImg :: IrcSummary -> Maybe (Image', Identifier, Maybe Identifier)-metadataImg msg =+metadataImg :: Palette -> IrcSummary -> Maybe (Image', Identifier, Maybe Identifier)+metadataImg pal msg =   case msg of-    QuitSummary who _   -> Just (char (withForeColor defAttr red   ) 'x', who, Nothing)-    PartSummary who     -> Just (char (withForeColor defAttr red   ) '-', who, Nothing)-    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--+    QuitSummary who _     -> Just (char (view palPart pal)   'x', who, Nothing)+    PartSummary who       -> Just (char (view palPart pal)   '-', who, Nothing)+    JoinSummary who       -> Just (char (view palJoin pal)   '+', who, Nothing)+    CtcpSummary who       -> Just (char (view palIgnore pal) 'C', who, Nothing)+    NickSummary old new   -> Just (char (view palUsrChg pal) '>', old, Just new)+    ChngSummary who       -> Just (char (view palUsrChg pal) '@', who, Nothing)+    AcctSummary who       -> Just (char (view palUsrChg pal) '*', who, Nothing)+    AwaySummary who True  -> Just (char (view palAway pal)   'a', who, Nothing)+    AwaySummary who False -> Just (char (view palUsrChg pal) 'b', who, Nothing)+    _                     -> Nothing  -- | Image used when treating ignored chat messages as metadata-ignoreImage :: Image'-ignoreImage = char (withForeColor defAttr yellow) 'I'+ignoreImage :: Palette -> Image'+ignoreImage pal = char (view palIgnore pal) 'I' +modesImage :: Attr -> HashMap Char Attr -> String -> Image'+modesImage def pal modes = foldMap modeImage modes+  where+    modeImage m =+      char (fromMaybe def (view (at m) pal)) m  -- | Render the normal view of a chat message line padded and wrapped. drawWindowLine ::@@ -1215,3 +1240,10 @@     wrap pfx body = reverse (lineWrapPrefix w pfx body)     drawPrefix = views wlTimestamp drawTime <>                  views wlPrefix    padNick++modesPaletteFor :: Identifier -> MessageRendererParams -> HashMap Char Attr+modesPaletteFor name rp+  | isChanPrefix $ Text.head $ idText name = view palCModes (rendNetPalette rp)+  | otherwise = view palUModes (rendNetPalette rp)+  where+    isChanPrefix c = c `elem` (rendChanTypes rp)

src/Client/Image/MircFormatting.hs view

@@ -19,19 +19,19 @@   , mircColors   ) where -import           Client.Image.PackedImage as I-import           Client.Image.Palette (Palette, palMonospace)-import           Control.Applicative ((<|>), empty)-import           Control.Lens-import           Data.Attoparsec.Text as Parse-import           Data.Bits-import           Data.Char-import           Data.Maybe-import           Data.Text (Text)-import           Graphics.Vty.Attributes-import           Data.Vector (Vector)-import qualified Data.Vector as Vector-import           Numeric (readHex)+import Client.Image.PackedImage as I+import Client.Image.Palette (Palette, palMonospace)+import Control.Applicative ((<|>), empty)+import Control.Lens (view, over, set, makeLensesFor)+import Data.Attoparsec.Text as Parse+import Data.Bits (Bits(xor))+import Data.Char (ord, chr, isControl, isHexDigit)+import Data.Maybe (fromMaybe, isNothing)+import Data.Text (Text)+import Data.Vector (Vector)+import Data.Vector qualified as Vector+import Graphics.Vty.Attributes+import Numeric (readHex)  makeLensesFor   [ ("attrForeColor", "foreColorLens")@@ -166,7 +166,7 @@       235, 237, 239, 241, 244, 247, 250, 254, 231 ]  rgbColor' :: Int -> Int -> Int -> Color-rgbColor' = rgbColor -- fix the type to Int+rgbColor' = srgbColor -- fix the type to Int  applyControlEffect :: Char -> Attr -> Maybe Attr applyControlEffect '\^B' attr = Just $! toggleStyle bold attr

src/Client/Image/PackedImage.hs view

@@ -23,13 +23,13 @@   , resizeImage   ) where -import           Data.List (findIndex)-import qualified Data.Text as S-import qualified Data.Text.Lazy as L-import           Data.String-import           Graphics.Vty.Attributes-import           Graphics.Vty.Image ((<|>), wcswidth, wcwidth)-import           Graphics.Vty.Image.Internal (Image(..))+import Data.List (findIndex)+import Data.String (IsString(..))+import Data.Text qualified as S+import Data.Text.Lazy qualified as L+import Graphics.Vty.Attributes (Attr, defAttr)+import Graphics.Vty.Image ((<|>), wcswidth, wcwidth)+import Graphics.Vty.Image.Internal (Image(..))   unpackImage :: Image' -> Image

src/Client/Image/Palette.hs view

@@ -12,6 +12,7 @@   (   -- * Palette type     Palette(..)+  , NetworkPalette(..)    -- * Lenses   , palNicks@@ -32,31 +33,42 @@   , palCommandPlaceholder   , palCommandPrefix   , palCommandError-  , palCommandPrompt   , palWindowDivider   , palLineMarker+  , palAway+  , palMonospace+  , palJoin+  , palPart+  , palModes+  , palUsrChg+  , palIgnore++  -- * Lenses (Network)   , palCModes   , palUModes   , palSnomask-  , palAway-  , palMonospace+  , palIdOverride    , paletteMap+  , unifyNetworkPalette    -- * Defaults   , defaultPalette+  , defaultNetworkPalette   ) where -import           Control.Lens-import           Data.Text (Text)-import           Data.Vector (Vector)-import           Graphics.Vty.Attributes-import           Data.HashMap.Strict (HashMap)-import qualified Data.HashMap.Strict as HashMap+import Control.Lens (makeLenses, ReifiedLens(Lens), ReifiedLens')+import Data.HashMap.Strict (HashMap)+import Data.HashMap.Strict qualified as HashMap+import Data.Text (Text)+import Data.Vector (Vector)+import Graphics.Vty.Attributes+import Irc.Identifier  -- | Color palette used for rendering the client UI data Palette = Palette-  { _palNicks         :: Vector Attr -- ^ highlighting nicknames+  { _palNicks         :: Vector Attr -- ^ highlighting identifiers+  , _palIdOverride    :: HashMap Identifier Attr -- ^ overrides for specific identifiers   , _palSelf          :: Attr -- ^ own nickname(s)   , _palSelfHighlight :: Attr -- ^ own nickname(s) in mentions   , _palTime          :: Attr -- ^ message timestamps@@ -74,58 +86,90 @@   , _palCommandPrefix :: Attr -- ^ prefix of known command   , _palCommandError  :: Attr -- ^ unknown command   , _palCommandPlaceholder :: Attr -- ^ command argument placeholder-  , _palCommandPrompt :: Attr -- ^ Command input prefix @CMD:@   , _palWindowDivider :: Attr -- ^ Divider between split windows   , _palLineMarker    :: Attr -- ^ Divider between new and old messages   , _palAway          :: Attr -- ^ color of nickname when away   , _palMonospace     :: Attr -- ^ rendering of monospace formatting text-  , _palCModes        :: HashMap Char Attr -- ^ channel mode attributes+  , _palModes         :: Attr -- ^ mode lines+  , _palJoin          :: Attr+  , _palPart          :: Attr+  , _palUsrChg        :: Attr+  , _palIgnore        :: Attr+  }+  deriving Show++data NetworkPalette = NetworkPalette+  { _palCModes        :: HashMap Char Attr -- ^ channel mode attributes   , _palUModes        :: HashMap Char Attr -- ^ user mode attributes   , _palSnomask       :: HashMap Char Attr -- ^ snotice mask attributes   }   deriving Show  makeLenses ''Palette+makeLenses ''NetworkPalette --- | Default UI colors that look nice in my dark solarized color scheme+-- | Default UI colors defaultPalette :: Palette defaultPalette = Palette-  { _palNicks                   = defaultNickColorPalette-  , _palSelf                    = withForeColor defAttr red-  , _palSelfHighlight           = withForeColor defAttr red-  , _palTime                    = withForeColor defAttr brightBlack-  , _palMeta                    = withForeColor defAttr brightBlack-  , _palSigil                   = withForeColor defAttr cyan-  , _palLabel                   = withForeColor defAttr green-  , _palLatency                 = withForeColor defAttr yellow-  , _palWindowName              = withForeColor defAttr cyan-  , _palError                   = withForeColor defAttr red-  , _palTextBox                 = withForeColor defAttr brightBlack-  , _palActivity                = withForeColor defAttr green-  , _palMention                 = withForeColor defAttr red-  , _palCommand                 = withForeColor defAttr yellow-  , _palCommandReady            = withForeColor defAttr green-  , _palCommandPrefix           = withForeColor defAttr blue-  , _palCommandError            = withForeColor defAttr red-  , _palCommandPlaceholder      = withStyle defAttr reverseVideo-  , _palCommandPrompt           = defAttr `withStyle` bold `withBackColor` green `withForeColor` white-  , _palWindowDivider           = withStyle defAttr reverseVideo-  , _palLineMarker              = defAttr-  , _palAway                    = withForeColor defAttr brightBlack-  , _palMonospace               = defAttr-  , _palCModes                  = HashMap.empty-  , _palUModes                  = HashMap.empty-  , _palSnomask                 = HashMap.empty+  { _palNicks              = defaultNickColorPalette+  , _palIdOverride         = HashMap.empty+  , _palSelf               = withForeColor defAttr brightWhite+  , _palSelfHighlight      = defAttr `withBackColor` brightYellow `withForeColor` black+  , _palTime               = withForeColor defAttr brightBlack+  , _palMeta               = metaNo+  , _palSigil              = defAttr `withStyle` bold `withForeColor` brightYellow+  , _palLabel              = withForeColor defAttr cyan+  , _palLatency            = withForeColor defAttr green+  , _palWindowName         = withForeColor defAttr brightCyan+  , _palError              = defAttr `withStyle` bold `withForeColor` red+  , _palTextBox            = withForeColor defAttr brightBlack+  , _palActivity           = metaLo+  , _palMention            = metaHi+  , _palCommand            = withForeColor defAttr yellow+  , _palCommandReady       = withForeColor defAttr brightGreen+  , _palCommandPrefix      = withForeColor defAttr yellow+  , _palCommandError       = withForeColor defAttr red+  , _palCommandPlaceholder = withForeColor defAttr brightBlack+  , _palWindowDivider      = withStyle defAttr reverseVideo+  , _palLineMarker         = withForeColor defAttr cyan+  , _palAway               = withForeColor defAttr blue+  , _palMonospace          = defAttr+  , _palJoin               = withForeColor defAttr brightGreen+  , _palPart               = withForeColor defAttr brightRed+  , _palModes              = metaLo+  , _palUsrChg             = metaLo+  , _palIgnore             = withForeColor defAttr white   }+  where+    metaNo = withForeColor defAttr brightBlack+    metaLo = withForeColor defAttr brightBlue+    metaHi = defAttr `withStyle` bold `withBackColor` brightMagenta `withForeColor` black +defaultNetworkPalette :: NetworkPalette+defaultNetworkPalette = NetworkPalette+  { _palCModes = HashMap.empty+  , _palUModes = HashMap.empty+  , _palSnomask= HashMap.empty+  } -- | Default nick highlighting colors that look nice in my dark solarized -- color scheme. defaultNickColorPalette :: Vector Attr defaultNickColorPalette =   withForeColor defAttr <$>-    [cyan, magenta, green, yellow, blue,-     brightCyan, brightMagenta, brightGreen, brightBlue]+    [ Color240  18, Color240  19, Color240  20, Color240  21, Color240  22, Color240  23+    , Color240  24, Color240  25, Color240  26, Color240  27, Color240  28, Color240  29+    , Color240 192, Color240 193, Color240 194, Color240 195, Color240 196, Color240 197+    , Color240 198, Color240 199, Color240 200, Color240 201, Color240 202, Color240 203+    ] +-- | Combine one NetworkPalette with another.+unifyNetworkPalette :: NetworkPalette -> NetworkPalette -> NetworkPalette+unifyNetworkPalette defaults net = NetworkPalette+  { _palCModes     = HashMap.union (_palCModes net)     (_palCModes defaults)+  , _palUModes     = HashMap.union (_palUModes net)     (_palUModes defaults)+  , _palSnomask    = HashMap.union (_palSnomask net)    (_palSnomask defaults)+  } -- TODO: Replace the above with a nicer lens pattern later.+ -- | List of palette entry names and lenses for accessing that component -- of the palette. paletteMap :: [(Text, ReifiedLens' Palette Attr)]@@ -134,6 +178,7 @@   , ("self-highlight"   , Lens palSelfHighlight)   , ("time"             , Lens palTime)   , ("meta"             , Lens palMeta)+  , ("modes"            , Lens palModes)   , ("sigil"            , Lens palSigil)   , ("label"            , Lens palLabel)   , ("latency"          , Lens palLatency)@@ -147,9 +192,12 @@   , ("command-placeholder", Lens palCommandPlaceholder)   , ("command-prefix"   , Lens palCommandPrefix)   , ("command-error"    , Lens palCommandError)-  , ("command-prompt"   , Lens palCommandPrompt)   , ("window-divider"   , Lens palWindowDivider)   , ("line-marker"      , Lens palLineMarker)   , ("away"             , Lens palAway)   , ("monospace"        , Lens palMonospace)+  , ("join"             , Lens palJoin)+  , ("part"             , Lens palPart)+  , ("user-change"      , Lens palUsrChg)+  , ("ignore"           , Lens palIgnore)   ]

src/Client/Image/StatusLine.hs view

@@ -17,26 +17,26 @@   , clientTitle   ) where -import           Client.Image.Message (cleanChar, cleanText)-import           Client.Image.PackedImage-import           Client.Image.Palette-import           Client.State-import           Client.State.Channel-import           Client.State.Focus-import           Client.State.Network-import           Client.State.Window-import           Control.Lens-import           Data.Foldable (for_)-import qualified Data.Map.Strict as Map-import           Data.Maybe-import           Data.HashMap.Strict (HashMap)-import           Data.Text (Text)-import qualified Data.Text as Text-import qualified Data.Text.Lazy as LText-import           Graphics.Vty.Attributes-import qualified Graphics.Vty.Image as Vty-import           Irc.Identifier (idText)-import           Numeric+import Client.Image.Message (cleanChar, cleanText, IdentifierColorMode (NormalIdentifier), coloredIdentifier, modesImage)+import Client.Image.PackedImage+import Client.Image.Palette+import Client.State+import Client.State.Channel (chanModes, chanUsers)+import Client.State.Focus (focusNetwork, Focus(..), Subfocus(..), WindowsFilter(..))+import Client.State.Network+import Client.State.Window+import Control.Lens (view, orOf, preview, views, _Just, Ixed(ix))+import Data.Foldable (for_)+import Data.Map.Strict qualified as Map+import qualified Data.HashMap.Strict as HashMap+import Data.Maybe (mapMaybe, maybeToList)+import Data.Text (Text)+import Data.Text qualified as Text+import Data.Text.Lazy qualified as LText+import Graphics.Vty.Attributes (Attr, defAttr, bold, withForeColor, withStyle, red)+import Graphics.Vty.Image qualified as Vty+import Irc.Identifier (idText)+import Numeric (showFFloat)  clientTitle :: ClientState -> String clientTitle st@@ -224,7 +224,6 @@       let name = case view winName w of                    Nothing -> '?'                    Just i -> i in-      if view winSilent w then rest else       case view winMention w of         WLImportant -> Vty.char (view palMention  pal) name : rest         WLNormal    -> Vty.char (view palActivity pal) name : rest@@ -241,13 +240,13 @@    where     baraux (focus,w)-      | view winSilent w = Nothing+      | view winActivityFilter w == AFSilent = Nothing       | n == 0 = Nothing -- todo: make configurable       | otherwise = Just                   $ unpackImage bar Vty.<|>                     Vty.char defAttr '[' Vty.<|>                     jumpLabel Vty.<|>-                    Vty.text' (view palLabel pal) (cleanText focusText) Vty.<|>+                    focusLabel Vty.<|>                     Vty.char defAttr ':' Vty.<|>                     Vty.string attr (show n) Vty.<|>                     Vty.char defAttr ']'@@ -262,11 +261,11 @@         attr = case view winMention w of                  WLImportant -> view palMention pal                  _           -> view palActivity pal-        focusText =-          case focus of-            Unfocused           -> Text.pack "*"-            NetworkFocus net    -> net-            ChannelFocus _ chan -> idText chan+        focusLabel =+          unpackImage $ case focus of+            Unfocused           -> text' (view palLabel pal) (Text.pack "*")+            NetworkFocus net    -> text' (view palLabel pal) (cleanText net)+            ChannelFocus _ chan -> coloredIdentifier pal NormalIdentifier HashMap.empty chan   -- | Pack a list of images into a single image spanning possibly many lines.@@ -301,13 +300,14 @@     Unfocused                 -> Vty.emptyImage   where     pal = clientPalette st+    netpal = clientNetworkPalette st     nickPart network =       case preview (clientConnection network) st of         Nothing -> Vty.emptyImage         Just cs -> Vty.text' attr (cleanText (idText nick))            Vty.<|> parens defAttr                      (unpackImage $-                      modesImage (view palUModes pal) (view csModes cs) <>+                      modesImage (view palModes pal) (view palUModes netpal) ('+':view csModes cs) <>                       snomaskImage)           where             attr@@ -318,13 +318,8 @@              snomaskImage               | null (view csSnomask cs) = ""-              | otherwise                = " " <> modesImage (view palSnomask pal) (view csSnomask cs)--modesImage :: HashMap Char Attr -> String -> Image'-modesImage pal modes = "+" <> foldMap modeImage modes-  where-    modeImage m =-      char (fromMaybe defAttr (view (at m) pal)) m+              | otherwise                = " " <>+                modesImage (view palModes pal) (view palSnomask netpal) ('+':view csSnomask cs)  subfocusImage :: Subfocus -> ClientState -> Image' subfocusImage subfocus st = foldMap infoBubble (viewSubfocusLabel pal subfocus)@@ -346,8 +341,10 @@  viewFocusLabel :: ClientState -> Focus -> Image' viewFocusLabel st focus =-  let !pal = clientPalette st in-  case focus of+  let+    !pal = clientPalette st+    netpal = clientNetworkPalette st+  in case focus of     Unfocused ->       char (view palError pal) '*'     NetworkFocus network ->@@ -356,7 +353,7 @@       text' (view palLabel pal) (cleanText network) <>       char defAttr ':' <>       string (view palSigil pal) (cleanChar <$> sigils) <>-      text' (view palLabel pal) (cleanText (idText channel)) <>+      coloredIdentifier pal NormalIdentifier HashMap.empty channel <>       channelModes        where@@ -369,7 +366,7 @@                 , case preview (csChannels . ix channel . chanModes) cs of                     Just modeMap | not (null modeMap) ->-                        " " <> modesImage (view palCModes pal) (Map.keys modeMap)+                        " " <> modesImage (view palModes pal) (view palCModes netpal) ('+':Map.keys modeMap)                     _ -> mempty                ) @@ -382,7 +379,6 @@     FocusInfo         -> Just $ string (view palLabel pal) "info"     FocusUsers        -> Just $ string (view palLabel pal) "users"     FocusMentions     -> Just $ string (view palLabel pal) "mentions"-    FocusDCC          -> Just $ string (view palLabel pal) "dcc"     FocusPalette      -> Just $ string (view palLabel pal) "palette"     FocusDigraphs     -> Just $ string (view palLabel pal) "digraphs"     FocusKeyMap       -> Just $ string (view palLabel pal) "keymap"@@ -390,6 +386,8 @@     FocusIgnoreList   -> Just $ string (view palLabel pal) "ignores"     FocusRtsStats     -> Just $ string (view palLabel pal) "rtsstats"     FocusCert{}       -> Just $ string (view palLabel pal) "cert"+    FocusChanList _ _ -> Just $ string (view palLabel pal) "channels"+    FocusWho          -> Just $ string (view palLabel pal) "who"     FocusMasks m      -> Just $ mconcat       [ string (view palLabel pal) "masks"       , char defAttr ':'

src/Client/Image/Textbox.hs view

@@ -15,26 +15,26 @@   ( textboxImage   ) where -import           Client.Configuration-import           Client.Commands-import           Client.Commands.Arguments.Renderer-import           Client.Commands.Arguments.Parser-import           Client.Commands.Interpolation-import           Client.Commands.Recognizer-import           Client.Image.LineWrap (fullLineWrap, terminate)-import           Client.Image.Message-import           Client.Image.MircFormatting-import           Client.Image.PackedImage-import           Client.Image.Palette-import           Client.State-import qualified Client.State.EditBox as Edit-import           Control.Lens-import           Data.HashMap.Strict (HashMap)-import           Data.List-import qualified Data.Text as Text-import           Graphics.Vty.Attributes-import qualified Graphics.Vty.Image as Vty-import           Irc.Identifier+import Client.Configuration+import Client.Commands (Command(Command, cmdArgumentSpec), commands)+import Client.Commands.Arguments.Renderer (render)+import Client.Commands.Arguments.Parser (parse)+import Client.Commands.Interpolation (Macro(macroSpec), MacroSpec(..))+import Client.Commands.Recognizer+import Client.Image.LineWrap (fullLineWrap, terminate)+import Client.Image.Message (cleanChar, parseIrcTextWithNicks, Highlight)+import Client.Image.MircFormatting (parseIrcText', plainText)+import Client.Image.PackedImage (char, imageWidth, string, unpackImage, Image')+import Client.Image.Palette+import Client.State+import Client.State.EditBox qualified as Edit+import Control.Lens (view, views)+import Data.HashMap.Strict (HashMap)+import Data.List (intersperse)+import Data.Text qualified as Text+import Graphics.Vty.Attributes (defAttr)+import Graphics.Vty.Image qualified as Vty+import Irc.Identifier (Identifier)  textboxImage :: Int -> Int -> ClientState -> (Int, Int, Int, Vty.Image) -- ^ cursor column, new offset, image textboxImage maxHeight width st =

src/Client/Log.hs view

@@ -11,20 +11,20 @@ -} module Client.Log where -import           Client.Image.Message (cleanText)-import           Client.Message-import           Control.Exception-import           Control.Lens hiding ((<.>))-import           Data.Time-import           Data.Text (Text)-import qualified Data.Text as Text-import qualified Data.Text.Lazy as L-import qualified Data.Text.Lazy.IO as L-import           Irc.Identifier-import           Irc.Message-import           Irc.UserInfo-import           System.Directory-import           System.FilePath+import Client.Image.Message (cleanText)+import Client.Message+import Control.Exception (try)+import Control.Lens (view)+import Data.Text (Text)+import Data.Text qualified as Text+import Data.Text.Lazy qualified as L+import Data.Text.Lazy.IO qualified as L+import Data.Time+import Irc.Identifier (Identifier, idText, idTextNorm )+import Irc.Message (IrcMsg(Ctcp, Privmsg, Notice), Source(srcUser))+import Irc.UserInfo (UserInfo(userNick))+import System.Directory (createDirectoryIfMissing)+import System.FilePath ((<.>), (</>))   -- | Log entry queued in client to be written by the event loop

src/Client/Mask.hs view

@@ -5,13 +5,13 @@   , buildMask   ) where -import Irc.UserInfo-import Irc.Identifier+import Data.List (intercalate) import Data.Text (Text)-import qualified Data.Text as Text+import Data.Text qualified as Text+import Irc.Identifier (Identifier, idTextNorm, mkId)+import Irc.UserInfo (UserInfo, renderUserInfo) import Text.Regex.TDFA import Text.Regex.TDFA.String (compile)-import Data.List  newtype Mask = Mask Regex

src/Client/Message.hs view

@@ -1,4 +1,4 @@-{-# Language OverloadedStrings, TemplateHaskell #-}+{-# Language OverloadedStrings, TemplateHaskell, PatternSynonyms #-} {-| Module      : Client.Message Description : Messages to be added to buffers@@ -36,13 +36,14 @@   , msgText   ) where -import           Control.Lens-import           Data.Text (Text)-import           Data.Time (ZonedTime)-import           Irc.Message-import           Irc.Identifier-import           Irc.UserInfo-import           Irc.Codes+import Control.Lens+import Data.Maybe (isJust)+import Data.Text (Text)+import Data.Time (ZonedTime)+import Irc.Codes (ReplyCode, pattern RPL_NOWAWAY, pattern RPL_UNAWAY )+import Irc.Identifier (Identifier, mkId)+import Irc.Message (IrcMsg(..), ircMsgText, Source(srcUser))+import Irc.UserInfo ( UserInfo(userNick) )  data MessageBody   = IrcBody    !IrcMsg@@ -74,6 +75,7 @@   | CtcpSummary {-# UNPACK #-} !Identifier   | ChngSummary {-# UNPACK #-} !Identifier -- ^ Chghost command   | AcctSummary {-# UNPACK #-} !Identifier -- ^ Account command+  | AwaySummary {-# UNPACK #-} !Identifier !Bool   | NoSummary   deriving (Eq, Show) @@ -103,9 +105,12 @@     Ctcp who _ "ACTION" _ -> ChatSummary (srcUser who)     Ctcp who _ _ _ -> CtcpSummary (userNick (srcUser who))     CtcpNotice who _ _ _ -> ChatSummary (srcUser who)+    Reply _ RPL_NOWAWAY (who:_) -> AwaySummary (mkId who) True+    Reply _ RPL_UNAWAY  (who:_) -> AwaySummary (mkId who) False     Reply _ code _  -> ReplySummary code     Account who _   -> AcctSummary (userNick (srcUser who))     Chghost who _ _ -> ChngSummary (userNick (srcUser who))+    Away who mb     -> AwaySummary (userNick (srcUser who)) (isJust mb)     _               -> NoSummary  quitKind :: Maybe Text -> QuitKind@@ -125,6 +130,6 @@     CtcpSummary who   -> Just who     AcctSummary who   -> Just who     ChngSummary who   -> Just who+    AwaySummary who _ -> Just who     ReplySummary {}   -> Nothing     NoSummary         -> Nothing-

src/Client/Network/Async.hs view

@@ -35,30 +35,30 @@   , TerminationReason(..)   ) where -import           Client.Configuration.ServerSettings-import           Client.Network.Connect-import           Control.Concurrent-import           Control.Concurrent.Async-import           Control.Concurrent.STM-import           Control.Exception-import           Control.Lens-import           Control.Monad-import           Data.ByteString (ByteString)-import qualified Data.ByteString as B-import           Data.Foldable-import           Data.List-import           Data.List.Split (chunksOf)-import           Data.Text (Text)-import qualified Data.Text as Text-import           Data.Time-import           Data.Traversable-import           Data.Word (Word8)-import           Hookup-import           Hookup.OpenSSL (getPubKeyDer)-import           Irc.RateLimit-import           Numeric (showHex)-import qualified OpenSSL.EVP.Digest as Digest-import           OpenSSL.X509 (X509, printX509, writeDerX509)+import Client.Configuration.ServerSettings+import Client.Network.Connect (withConnection, tlsParams)+import Control.Concurrent (MVar, swapMVar, threadDelay, forkIO, newEmptyMVar, putMVar)+import Control.Concurrent.Async (Async, async, cancel, cancelWith, race_, waitCatch, withAsync, AsyncCancelled(AsyncCancelled))+import Control.Concurrent.STM+import Control.Exception (SomeException, Exception(fromException, displayException), throwIO)+import Control.Lens (view)+import Control.Monad (join, when, forever, unless)+import Data.ByteString (ByteString)+import Data.ByteString qualified as B+import Data.Foldable (for_)+import Data.List (intercalate)+import Data.List.Split (chunksOf)+import Data.Text (Text)+import Data.Text qualified as Text+import Data.Time (ZonedTime, getZonedTime)+import Data.Traversable (for)+import Data.Word (Word8)+import Hookup+import Hookup.OpenSSL (getPubKeyDer)+import Irc.RateLimit (RateLimit, newRateLimit, tickRateLimit)+import Numeric (showHex)+import OpenSSL.EVP.Digest qualified as Digest+import OpenSSL.X509 (X509, printX509, writeDerX509)   -- | Handle for a network connection

src/Client/Network/Connect.hs view

@@ -20,13 +20,13 @@   , tlsParams   ) where -import           Client.Configuration.ServerSettings-import           Control.Applicative-import           Control.Exception  (bracket)-import           Control.Lens-import qualified Data.Text.Encoding as Text-import           Network.Socket (PortNumber)-import           Hookup+import Client.Configuration.ServerSettings+import Control.Applicative ((<|>))+import Control.Exception  (bracket)+import Control.Lens (view, (<&>))+import Data.Text.Encoding qualified as Text+import Hookup+import Network.Socket (PortNumber)  tlsParams :: ServerSettings -> TlsParams tlsParams ss = TlsParams@@ -45,7 +45,15 @@ proxyParams :: ServerSettings -> Maybe SocksParams proxyParams ss =   view ssSocksHost ss <&> \host ->-  SocksParams host (view ssSocksPort ss)+  SocksParams {+    spHost = host,+    spPort = view ssSocksPort ss,+    spAuth =+      case (view ssSocksUsername ss, view ssSocksPassword ss) of+        (Just u, Just (SecretText p)) ->+          UsernamePasswordSocksAuthentication (Text.encodeUtf8 u) (Text.encodeUtf8 p)+        _ -> NoSocksAuthentication+  }  buildConnectionParams :: ServerSettings -> ConnectionParams buildConnectionParams ss = ConnectionParams@@ -72,5 +80,5 @@ -- | Create a new 'Connection' which will be closed when the continuation -- finishes. withConnection :: ServerSettings -> (Connection -> IO a) -> IO a-withConnection settings k =-  bracket (connect (buildConnectionParams settings)) close k+withConnection settings =+  bracket (connect (buildConnectionParams settings)) close

src/Client/Options.hs view

@@ -32,23 +32,22 @@   , getOptions   ) where -import           Config.Schema.Docs-import           Control.Lens-import           Data.Foldable-import           Data.List-import           Data.Text (Text)-import qualified Data.Text as Text-import           Data.Version-import           GitHash (giHash, giDirty, tGitInfoCwdTry)-import           System.Console.GetOpt-import           System.Environment-import           System.Exit-import           System.IO-import           System.Info-import           Paths_glirc (version)-import           Build_glirc (deps)--import           Client.Configuration+import Build_glirc (deps)+import Client.Configuration (configurationSpec, getConfigPath)+import Config.Schema.Docs (generateDocs)+import Control.Lens (view, (<>~), set, makeLenses)+import Data.Foldable (Foldable(foldl'), traverse_)+import Data.List (intercalate, sort)+import Data.Text (Text)+import Data.Text qualified as Text+import Data.Version (showVersion)+import GitHash (giHash, giDirty, tGitInfoCwdTry)+import Paths_glirc (version)+import System.Console.GetOpt+import System.Environment (getArgs)+import System.Exit (exitFailure, exitSuccess)+import System.Info (arch, compilerName, compilerVersion, os)+import System.IO (hPutStr, hPutStrLn, stderr)  -- | Command-line options data Options = Options

src/Client/State.hs view

@@ -36,7 +36,9 @@   , clientIgnores   , clientIgnoreMask   , clientConnection+  , clientNotifications   , clientBell+  , clientUiFocused   , clientExtensions   , clientRegex   , clientLogQueue@@ -54,6 +56,8 @@   , withClientState   , clientIsFiltered   , clientFilter+  , clientFilterChannels+  , clientNetworkPalette   , buildMatcher   , clientToggleHideMeta   , channelUserList@@ -74,6 +78,7 @@   , clientAutoconnects   , clientActiveCommand   , clientNextWindowName+  , clientWindowHint    , clientExtraFocuses   , currentNickCompletionMode@@ -104,11 +109,6 @@   , esActive   , esMVar   , esStablePtr--  -- * URL view-  , urlPattern-  , urlMatches-   ) where  import           Client.CApi@@ -117,6 +117,7 @@ import           Client.Configuration.ServerSettings import           Client.Configuration.Sts import           Client.Image.Message+import           Client.Image.PackedImage (imageText) import           Client.Image.Palette import           Client.Log import           Client.Mask@@ -161,7 +162,6 @@ import           Text.Regex.TDFA import           Text.Regex.TDFA.String (compile) - -- | All state information for the IRC client data ClientState = ClientState   { _clientWindows           :: !(Map Focus Window) -- ^ client message buffers@@ -192,7 +192,9 @@   , _clientEditMode          :: EditMode                  -- ^ editor rendering mode   , _clientEditLock          :: Bool                      -- ^ editor locked and won't send -  , _clientBell              :: !Bool                     -- ^ sound a bell next draw+  , _clientNotifications     :: [(LText.Text, LText.Text)] -- ^ notifications to send next draw+  , _clientBell              :: !Bool                     -- ^ terminal bell on next redraw+  , _clientUiFocused         :: !Bool                     -- ^ whether the UI is focused; used by notifications    , _clientIgnores           :: !(HashSet Identifier)     -- ^ ignored masks   , _clientIgnoreMask        :: Mask                      -- ^ precomputed ignore regular expression (lazy)@@ -282,7 +284,9 @@         , _clientEditLock          = False         , _clientActivityBar       = view configActivityBar cfg         , _clientShowPing          = view configShowPing cfg+        , _clientNotifications     = []         , _clientBell              = False+        , _clientUiFocused         = True         , _clientExtensions        = exts         , _clientLogQueue          = []         , _clientErrorMsg          = Nothing@@ -322,6 +326,7 @@     , _msgNetwork = ""     } ste + -- | Add a message to the window associated with a given channel recordChannelMessage ::   Text       {- ^ network -} ->@@ -329,9 +334,18 @@   ClientMessage ->   ClientState ->   ClientState-recordChannelMessage network channel msg st+recordChannelMessage = recordChannelMessage' True++recordChannelMessage' ::+  Bool       {- ^ create  -} ->+  Text       {- ^ network -} ->+  Identifier {- ^ channel -} ->+  ClientMessage ->+  ClientState ->+  ClientState+recordChannelMessage' create network channel msg st   = recordLogLine msg statusModes channel'-  $ recordWindowLine focus wl st+  $ recordWindowLine' create focus wl st   where     focus      = ChannelFocus network channel'     wl         = toWindowLine rendParams importance msg@@ -342,6 +356,8 @@       , rendHighlights  = highlights       , rendPalette     = clientPalette st       , rendAccounts    = accounts+      , rendNetPalette  = clientNetworkPalette st+      , rendChanTypes   = "#&!+" -- TODO: Don't hardcode this, use CHANTYPES ISUPPORT.       }      -- on failure returns mempty/""@@ -420,6 +436,14 @@                           | otherwise   -> WLNormal         Error{} -> WLImportant +        -- away notices+        Reply _ RPL_AWAY _     -> WLBoring++        -- list output+        Reply _ RPL_LISTSTART _ -> WLBoring+        Reply _ RPL_LIST      _ -> WLBoring+        Reply _ RPL_LISTEND   _ -> WLBoring+         -- channel information         Reply _ RPL_TOPIC _    -> WLBoring         Reply _ RPL_INVITING _ -> WLBoring@@ -468,20 +492,10 @@ recordIrcMessage network target msg st =   updateTransientError (NetworkFocus network) msg $   case target of-    TargetNetwork     -> recordNetworkMessage msg st-    TargetWindow chan -> recordChannelMessage network chan msg st-    TargetUser user   ->-      foldl' (\st' chan -> overStrict-                             (clientWindows . ix (ChannelFocus network chan))-                             (addToWindow wl) st')-           st chans-      where-        wl    = toWindowLine' network st WLBoring msg-        chans = user-              : case preview (clientConnection network . csChannels) st of-                  Nothing -> []-                  Just m  -> [chan | (chan, cs) <- HashMap.toList m-                                   , HashMap.member user (view chanUsers cs) ]+    TargetNetwork      -> recordNetworkMessage msg st+    TargetExisting win -> recordChannelMessage' False network win  msg st+    TargetWindow chan  -> recordChannelMessage' True  network chan msg st+    TargetUser user    -> recordUserMessage network user msg st  -- | Compute the sigils of the user who sent a message. computeMsgLineSigils ::@@ -540,6 +554,27 @@     importance = msgImportance msg st     wl         = toWindowLine' network st importance msg +-- | Record a message on every window where a user is present.+recordUserMessage ::+  Text       {- ^ network -} ->+  Identifier {- ^ user -} ->+  ClientMessage ->+  ClientState ->+  ClientState+recordUserMessage network user msg st = foldl' foldFn st chans+  where+    -- FIXME: We discard the the boolean from addToWindow here,+    -- which means notifications for important cross-channel activity never happen.+    -- This currently affects nothing AFAIK, but who knows what the future holds?+    windowsLens chan = clientWindows . ix (ChannelFocus network chan)+    foldFn st' chan = overStrict (windowsLens chan) (fst . addToWindow wl) st'+    wl    = toWindowLine' network st WLBoring msg+    chans = user+          : case preview (clientConnection network . csChannels) st of+              Nothing -> []+              Just m  -> [chan | (chan, cs) <- HashMap.toList m+                               , HashMap.member user (view chanUsers cs) ]+ recordError ::   ZonedTime       {- ^ now             -} ->   Text            {- ^ network         -} ->@@ -553,40 +588,79 @@     , _msgBody    = ErrorBody msg     } -clientNextWindowName :: ClientState -> Char-clientNextWindowName st =-  case clientWindowNames st \\ usedNames of-    []  -> '\0'-    c:_ -> c+clientNextWindowName :: Maybe WindowHint -> ClientState -> Char+clientNextWindowName hint st+  | Just n <- windowHintName =<< hint, n `notElem` usedNames = n+  | c:_ <- availableNames \\ usedNames    = c+  | otherwise                             = '\0'   where     usedNames = toListOf (clientWindows . folded . winName . _Just) st +    availableNames :: String+    availableNames = clientWindowNames st \\ reservedNames++    reservedNames :: String+    reservedNames =+      toListOf (clientConnections . folded . csSettings . ssWindowHints . folded . to windowHintName  . folded) st++clientWindowHint :: Focus -> ClientState -> Maybe WindowHint+clientWindowHint focus st =+ do net <- focusNetwork focus+    let hintFocus =+          case focus of+            Unfocused -> Unfocused+            NetworkFocus {} -> NetworkFocus ""+            ChannelFocus _ x -> ChannelFocus "" x+    preview (clientConnection net . csSettings . ssWindowHints . ix hintFocus) st+ -- | Record window line at the given focus creating the window if necessary recordWindowLine ::   Focus ->   WindowLine ->   ClientState ->   ClientState-recordWindowLine focus wl st = st2+recordWindowLine = recordWindowLine' True++recordWindowLine' ::+  Bool ->+  Focus ->+  WindowLine ->+  ClientState ->+  ClientState+recordWindowLine' create focus wl st = st1   where+    hints = clientWindowHint focus st+    winActivity = fromMaybe AFLoud (windowHintActivity =<< hints)+     freshWindow = emptyWindow-      { _winName' = clientNextWindowName st-      , _winHideMeta = view (clientConfig . configHideMeta) st+      { _winName'    = clientNextWindowName hints st+      , _winHideMeta = fromMaybe (view (clientConfig . configHideMeta) st) (windowHintHideMeta =<< hints)+      , _winHidden   = fromMaybe False (windowHintHidden =<< hints)+      , _winActivityFilter   = winActivity       } -    st1 = over (clientWindows . at focus)-               (\w -> Just $! addToWindow wl (fromMaybe freshWindow w))-               st--    st2-      | not (view clientBell st)-      , view (clientConfig . configBellOnMention) st-      , view wlImportance wl == WLImportant-      , not (hasMention st) = set clientBell True st1+    add True  w = Just $! addToWindow wl (fromMaybe freshWindow w)+    add False w = addToWindow wl <$> w -      | otherwise = st1+    addedMaybe = add create $ view (clientWindows . at focus) st+    st1 = case addedMaybe of+      Just (w', notify) -> addNotify notify focus wl $ set (clientWindows . at focus) (Just w') st+      Nothing -> st -    hasMention = elemOf (clientWindows . folded . winMention) WLImportant+addNotify :: Bool -> Focus -> WindowLine -> ClientState -> ClientState+addNotify False _     _  st = st+addNotify True  focus wl st+  | focus == view clientFocus st && view clientUiFocused st = st+  | otherwise = addBell $ over clientNotifications (cons (focusText focus, bodyText)) st+  where+    addBell st'+      | not (view clientBell st')+      , view (clientConfig . configBellOnMention) st' = set clientBell True st'+      | otherwise = st'+    bodyText = imageText (view wlPrefix wl) <> " " <> imageText (view wlImage wl)+    focusText Unfocused = "Application Notice"+    focusText (NetworkFocus net) = LText.fromChunks ["Notice from ", net]+    focusText (ChannelFocus net chan) = LText.fromChunks ["Activity on ", net, ":", idText chan]  toWindowLine :: MessageRendererParams -> WindowLineImportance -> ClientMessage -> WindowLine toWindowLine params importance msg = WindowLine@@ -611,9 +685,11 @@  -- | Function applied to the client state every redraw. clientTick :: ClientState -> ClientState-clientTick = set clientBell False-           . markSeen+clientTick st = (if view clientUiFocused st then markSeen else id)+           . set clientBell False+           . set clientNotifications []            . set clientLogQueue []+           $ st   -- | Mark the messages on the current window (and any splits) as seen.@@ -692,6 +768,19 @@      where        limit = maybe id take (matcherMax m) +clientFilterChannels ::+  ClientState ->+  Maybe Int ->+  Maybe Int ->+  [(Identifier, Int, Text)] ->+  [(Identifier, Int, Text)]+clientFilterChannels st min' (Just max') =+  filter (\(_, users, _) -> users < max') . clientFilterChannels st min' Nothing+clientFilterChannels st (Just min') Nothing =+  filter (\(_, users, _) -> users > min') . clientFilterChannels st Nothing Nothing+clientFilterChannels st Nothing Nothing = clientFilter st filterOn+  where filterOn (chan, _, topic) = LText.fromChunks [idText chan, " ", topic]+ data MatcherArgs = MatcherArgs   { argAfter     :: !Int   , argBefore    :: !Int@@ -752,33 +841,6 @@     _                -> Nothing  --- | Regular expression for matching HTTP/HTTPS URLs in chat text.-urlPattern :: Regex-Right urlPattern =-  compile-    defaultCompOpt-    defaultExecOpt{captureGroups=False}-    "https?://([[:alnum:]-]+\\.)*([[:alnum:]-]+)(:[[:digit:]]+)?(/[-0-9a-zA-Z$_.+!*'(),%?&=:@/;~#]*)?|\-    \<https?://[^>]*>|\-    \\\(https?://[^\\)]*\\)"----- | Find all the URL matches using 'urlPattern' in a given 'Text' suitable--- for being opened. Surrounding @<@ and @>@ are removed.-urlMatches :: LText.Text -> [Text]-urlMatches txt = removeBrackets . extractText . (^?! ix 0)-             <$> matchAll urlPattern (LText.unpack txt)-  where-    extractText (off,len) = LText.toStrict-                          $ LText.take (fromIntegral len)-                          $ LText.drop (fromIntegral off) txt--    removeBrackets t =-      case Text.uncons t of-       Just ('<',t') | not (Text.null t') -> Text.init t'-       Just ('(',t') | not (Text.null t') -> Text.init t'-       _                                  -> t- -- | Remove a network connection and unlink it from the network map. -- This operation assumes that the network connection exists and should -- only be applied once per connection.@@ -851,7 +913,7 @@   Text                       {- ^ network name             -} ->   NetworkState               {- ^ network connection state -} ->   ClientState                {- ^ client state             -} ->-  ([RawIrcMsg], ClientState) {- ^ response , DCC updates, updated state -}+  ([RawIrcMsg], ClientState) {- ^ response , updated state -} applyMessageToClientState time irc network cs st =   cs' `seq` (reply, st')   where@@ -921,8 +983,7 @@         Just focus -> changeFocus focus st         Nothing    -> st   where-    windowList   = filter (not . view winSilent . snd)-                 $ views clientWindows Map.toAscList st+    windowList   = views clientWindows Map.toAscList st     highPriority = find (\x -> WLImportant == view winMention (snd x)) windowList     lowPriority  = find (\x -> view winUnread (snd x) > 0) windowList @@ -1103,3 +1164,9 @@ clientToggleHideMeta :: ClientState -> ClientState clientToggleHideMeta st =   overStrict (clientWindows . ix (view clientFocus st) . winHideMeta) not st++-- | Generates the NetworkPalette for the current focus.+clientNetworkPalette :: ClientState -> NetworkPalette+clientNetworkPalette st = case focusNetwork (view clientFocus st) of+  Just net -> configNetworkPalette net (view clientConfig st)+  Nothing  -> defaultNetworkPalette

src/Client/State/Channel.hs view

@@ -44,17 +44,17 @@   , nickChange   ) where -import           Control.Lens-import           Data.HashMap.Strict-import qualified Data.HashMap.Strict as HashMap-import qualified Data.Map.Strict as Map-import           Data.Map.Strict (Map)-import           Data.Text (Text)-import qualified Data.Text as Text-import           Data.Time-import           Irc.Identifier-import           Irc.RawIrcMsg (RawIrcMsg)-import           Irc.UserInfo+import Control.Lens ((&), sans, (<<.~), over, set, makeLenses, At(at))+import Data.HashMap.Strict (HashMap)+import Data.HashMap.Strict qualified as HashMap+import Data.Map.Strict (Map)+import Data.Map.Strict qualified as Map+import Data.Text (Text)+import Data.Text qualified as Text+import Data.Time (UTCTime)+import Irc.Identifier (Identifier)+import Irc.RawIrcMsg (RawIrcMsg)+import Irc.UserInfo (UserInfo)  -- | Dynamic information about the state of an IRC channel data ChannelState = ChannelState

src/Client/State/EditBox.hs view

@@ -61,12 +61,12 @@    ) where -import           Client.State.EditBox.Content-import           Control.Lens hiding (below)-import           Data.List.NonEmpty (NonEmpty)-import           Digraphs (Digraph)-import           Data.Map (Map)-import           Data.Text (Text)+import Client.State.EditBox.Content+import Control.Lens hiding (below)+import Data.List.NonEmpty (NonEmpty)+import Data.Map (Map)+import Data.Text (Text)+import Digraphs (Digraph)   data EditBox = EditBox

src/Client/State/EditBox/Content.hs view

@@ -48,17 +48,17 @@   , digraph   ) where -import           Control.Applicative ((<|>))-import           Control.Lens hiding ((<|), below)-import           Control.Monad (guard)-import           Data.Char (isAlphaNum)-import           Data.List (find)-import           Data.List.NonEmpty (NonEmpty(..), (<|))-import           Data.Map (Map)-import qualified Data.Map as Map-import           Data.Text (Text)-import qualified Data.Text as Text-import           Digraphs (Digraph(..), lookupDigraph)+import Control.Applicative ((<|>))+import Control.Lens (view, views, (+~), (-~), over, set, makeClassy, makeLenses)+import Control.Monad (guard)+import Data.Char (isAlphaNum)+import Data.List (find)+import Data.List.NonEmpty (NonEmpty(..), (<|))+import Data.Map (Map)+import Data.Map qualified as Map+import Data.Text (Text)+import Data.Text qualified as Text+import Digraphs (Digraph(..), lookupDigraph)  data Line = Line   { _pos  :: !Int

src/Client/State/Extensions.hs view

@@ -20,26 +20,24 @@   , clientThreadJoin   ) where -import Control.Concurrent.MVar-import Control.Monad.IO.Class-import Control.Exception-import Control.Lens-import Control.Monad-import Data.Foldable-import Data.Text (Text)-import Data.Time-import Foreign.Ptr-import Foreign.StablePtr-import qualified Data.Text as Text-import qualified Data.IntMap as IntMap--import Irc.RawIrcMsg--import Client.State-import Client.Message import Client.CApi import Client.CApi.Types-import Client.Configuration+import Client.Configuration (configExtensions, ExtensionConfiguration)+import Client.Message+import Client.State+import Control.Concurrent.MVar (putMVar, takeMVar)+import Control.Exception (displayException, try)+import Control.Lens+import Control.Monad (foldM)+import Control.Monad.IO.Class (liftIO)+import Data.Foldable (find)+import Data.IntMap qualified as IntMap+import Data.Text (Text)+import Data.Text qualified as Text+import Data.Time (getZonedTime)+import Foreign.Ptr (Ptr, nullFunPtr)+import Foreign.StablePtr (castStablePtrToPtr)+import Irc.RawIrcMsg (RawIrcMsg)  -- | Start extensions after ensuring existing ones are stopped clientStartExtensions ::

src/Client/State/Focus.hs view

@@ -27,9 +27,9 @@   , _Unfocused   ) where -import           Control.Lens-import           Data.Text (Text)-import           Irc.Identifier+import Control.Lens (makePrisms)+import Data.Text (Text)+import Irc.Identifier (Identifier)  -- | Currently focused window data Focus@@ -45,7 +45,6 @@   = FocusMessages    -- ^ Show messages   | FocusInfo        -- ^ Show channel metadata   | FocusUsers       -- ^ Show channel user list-  | FocusDCC         -- ^ Show DCC offers list   | FocusMasks !Char -- ^ Show channel mask list for given mode   | FocusWindows WindowsFilter -- ^ Show client windows   | FocusPalette     -- ^ Show current palette@@ -56,6 +55,8 @@   | FocusRtsStats    -- ^ Show GHC RTS statistics   | FocusIgnoreList  -- ^ Show ignored masks   | FocusCert        -- ^ Show rendered certificate+  | FocusChanList (Maybe Int) (Maybe Int) -- ^ Show channel list+  | FocusWho -- ^ Show last reply to a WHO query   deriving (Eq,Show)  -- | Unfocused first, followed by focuses sorted by network.

src/Client/State/Network.hs view

@@ -27,6 +27,8 @@   -- * Lenses   , csNick   , csChannels+  , csChannelList+  , csWhoReply   , csSocket   , csModeTypes   , csChannelTypes@@ -49,6 +51,9 @@   , csAuthenticationState   , csSeed   , csAway+  , clsElist+  , clsDone+  , clsItems    -- * Cross-message state   , Transaction(..)@@ -80,46 +85,50 @@   , sendTopic   ) where -import qualified Client.Authentication.Ecdsa as Ecdsa-import qualified Client.Authentication.Ecdh as Ecdh-import qualified Client.Authentication.Scram as Scram-import           Client.Configuration.ServerSettings-import           Client.Network.Async-import           Client.State.Channel-import           Client.UserHost-import           Client.Hook (MessageHook)-import           Client.Hooks (messageHooks)-import           Control.Lens-import           Data.HashMap.Strict (HashMap)-import qualified Data.HashMap.Strict as HashMap-import qualified Data.HashSet as HashSet-import qualified Data.ByteString as B-import qualified Data.Map.Strict as Map-import           Data.Bits-import           Data.Foldable-import           Data.List-import qualified Data.List.NonEmpty as NonEmpty-import           Data.Maybe-import           Data.Text (Text)-import qualified Data.Text as Text-import qualified Data.Text.Encoding as Text-import qualified Data.Text.Read as Text-import           Data.Time-import           Data.Time.Clock.POSIX-import           Irc.Codes-import           Irc.Commands-import           Irc.Identifier-import           Irc.Message-import           Irc.Modes-import           Irc.RawIrcMsg-import           Irc.UserInfo-import           LensUtils-import qualified System.Random as Random-import qualified Data.ByteString.Base64 as B64+import Client.Authentication.Ecdh qualified as Ecdh+import Client.Authentication.Ecdsa qualified as Ecdsa+import Client.Authentication.Scram qualified as Scram+import Client.Configuration.ServerSettings+import Client.Hook (MessageHook)+import Client.Hooks (messageHooks)+import Client.Network.Async (abortConnection, send, NetworkConnection, TerminationReason(PingTimeout))+import Client.State.Channel+import Client.UserHost (UserAndHost(UserAndHost, _uhAccount))+import Client.WhoReply+import Control.Lens+import Data.Bits (Bits((.&.)))+import Data.ByteString qualified as B+import Data.ByteString.Base64 qualified as B64+import Data.Either qualified as Either+import Data.Foldable (for_, traverse_ )+import Data.HashMap.Strict (HashMap)+import Data.HashMap.Strict qualified as HashMap+import Data.HashSet qualified as HashSet+import Data.List (foldl', delete, intersect, sort, sortBy, union)+import Data.List.NonEmpty qualified as NonEmpty+import Data.Map.Strict qualified as Map+import Data.Maybe (fromMaybe, isJust, mapMaybe, listToMaybe)+import Data.Text (Text)+import Data.Text qualified as Text+import Data.Text.Encoding qualified as Text+import Data.Text.Read qualified as Text+import Data.Time+import Data.Time.Clock.POSIX (posixSecondsToUTCTime)+import Irc.Codes+import Irc.Commands+import Irc.Identifier (Identifier, idText, mkId)+import Irc.Message+import Irc.Modes+import Irc.RawIrcMsg+import Irc.UserInfo+import LensUtils (overStrict, setStrict)+import System.Random qualified as Random  -- | State tracked for each IRC connection data NetworkState = NetworkState   { _csChannels     :: !(HashMap Identifier ChannelState) -- ^ joined channels+  , _csChannelList  :: !ChannelList -- ^ cached ELIST parameter and /list output+  , _csWhoReply     :: !WhoReply -- ^ cached reply from the last WHO query   , _csSocket       :: !NetworkConnection -- ^ network socket   , _csModeTypes    :: !ModeTypes -- ^ channel mode meanings   , _csUmodeTypes   :: !ModeTypes -- ^ user mode meanings@@ -168,6 +177,13 @@   | PingConnecting !Int !(Maybe UTCTime) !ConnectRestriction -- ^ number of attempts, last known connection time   deriving Show +-- | Cached channel information from /list and elsewhere.+data ChannelList = ChannelList+  { _clsElist :: !(Maybe Text) -- ^ The last ELIST parameter used. Nothing is also used to trigger cache purges+  , _clsDone  :: !Bool -- ^ Whether to purge the hash map on receiving a new RPL_LIST+  , _clsItems :: ![(Identifier, Int, Text)] -- ^ The list of channel infos.+  }+ data ConnectRestriction   = NoRestriction       -- ^ no message restriction   | StartTLSRestriction -- ^ STARTTLS hasn't finished@@ -189,11 +205,25 @@   | CapLsTransaction [(Text, Maybe Text)]   deriving Show + makeLenses ''NetworkState+makeLenses ''ChannelList makePrisms ''Transaction makePrisms ''PingStatus makePrisms ''TimedAction +newChannelList :: Maybe Text -> Maybe (Identifier, Int, Text) -> ChannelList+newChannelList elist Nothing = ChannelList+  { _clsElist = elist+  , _clsDone = False+  , _clsItems = []+  }+newChannelList elist (Just v) = ChannelList+  { _clsElist = elist+  , _clsDone = False+  , _clsItems = [v]+  }+ defaultChannelTypes :: String defaultChannelTypes = "#&" @@ -271,6 +301,8 @@ newNetworkState network settings sock ping seed = NetworkState   { _csUserInfo     = UserInfo "*" "" ""   , _csChannels     = HashMap.empty+  , _csChannelList  = newChannelList Nothing Nothing+  , _csWhoReply     = finishWhoReply $ newWhoReply "" ""   , _csSocket       = sock   , _csChannelTypes = defaultChannelTypes   , _csModeTypes    = defaultModeTypes@@ -387,6 +419,7 @@         noReply (set (csUserInfo . uiHost) host cs)      -- /who <#channel> %tuhna,616+    -- TODO: Use a different magic token here?     Reply _ RPL_WHOSPCRPL [_me,"616",user,host,nick,acct] ->        let acct' = if acct == "0" then "*" else acct        in noReply (recordUser (UserInfo (mkId nick) user host) acct' cs)@@ -449,6 +482,26 @@      (n, cs')    = cs & csSeed %%~ Random.randomR range +doList :: [Text] -> NetworkState -> NetworkState+doList (_:chan:users:topic) cs+  | purge = set csChannelList (newChannelList elist (Just $! value)) cs+  | otherwise = set (csChannelList . clsItems) items' cs+  where+    items' = value:(_clsItems . _csChannelList $ cs)+    value = (mkId chan, usercount, fromMaybe "" (listToMaybe topic))+    usercount = fst . Either.fromRight (0, "") . Text.decimal $ users+    elist = _clsElist . _csChannelList $ cs+    purge = _clsDone . _csChannelList $ cs+doList _ cs = cs++doListEnd :: NetworkState -> NetworkState+doListEnd cs = set csChannelList ncl cs+  where+    ncl = ChannelList { _clsElist = elist, _clsDone = True, _clsItems = sorted }+    elist = _clsElist . _csChannelList $ cs+    sorted = sortBy sorter . _clsItems . _csChannelList $ cs+    sorter (_, aU, _) (_, bU, _) = compare bU aU+ doTopic :: ZonedTime -> UserInfo -> Identifier -> Text -> NetworkState -> NetworkState doTopic when user chan topic =   overChannel chan (setTopic topic . set chanTopicProvenance (Just $! prov))@@ -583,14 +636,15 @@       case args of         _me:_tgt:uname:host:_server:nick:_ ->           noReply $+          over csWhoReply (recordWhoReply args) $           over csTransaction (\t ->             let !x  = UserInfo (mkId nick) uname host                 !xs = view _WhoTransaction t             in WhoTransaction (x : xs))             cs         _ -> noReply cs--    RPL_ENDOFWHO -> noReply (massRegistration cs)+    RPL_WHOSPCRPL -> noReply (over csWhoReply (recordWhoXReply args) cs)+    RPL_ENDOFWHO -> noReply (over csWhoReply finishWhoReply $ massRegistration cs)      RPL_CHANNELMODEIS ->       case args of@@ -605,6 +659,10 @@     RPL_NOWAWAY -> noReply (set csAway True cs)     RPL_UNAWAY  -> noReply (set csAway False cs) +    -- /list+    RPL_LIST    -> noReply (doList args cs)+    RPL_LISTEND -> noReply (doListEnd cs)+     _ -> noReply cs  @@ -668,6 +726,9 @@     RPL_CREATIONTIME    -> True     RPL_CHANNEL_URL     -> True     RPL_NOTOPIC         -> True+    RPL_LISTSTART       -> True+    RPL_LIST            -> True+    RPL_LISTEND         -> True     _                   -> False  -- | Return 'True' for messages that should be hidden outside of@@ -768,7 +829,7 @@       ["multi-prefix", "batch", "znc.in/playback", "znc.in/self-message"       , "cap-notify", "extended-join", "account-notify", "chghost"       , "userhost-in-names", "account-tag", "solanum.chat/identify-msg"-      , "solanum.chat/realhost" ]+      , "solanum.chat/realhost", "away-notify"]      -- logic for using IRCv3.2 server-time if available and falling back     -- to ZNC's specific extension otherwise.

+ src/Client/State/Url.hs view

@@ -0,0 +1,116 @@+{-# LANGUAGE OverloadedStrings #-}++{-|+Module      : Client.State.Url+Description : Function for extracting URLs from text+Copyright   : (c) Eric Mertens, 2016+License     : ISC+Maintainer  : emertens@gmail.com++-}++module Client.State.Url+  ( UrlPair+  , urlList+  ) where++import           Client.Message (summaryActor)+import           Client.State+import           Client.State.Focus (Subfocus(..), focusNetwork, Focus)+import           Client.State.Network+import           Client.State.Window+import           Client.WhoReply+import           Control.Lens+import qualified Data.HashMap.Strict as HashMap+import qualified Data.List as List+import           Data.Maybe+import           Data.Text (Text)+import qualified Data.Text as Text+import qualified Data.Text.Lazy as LText+import           Irc.Identifier (Identifier)+import           Irc.UserInfo (UserInfo(..))+import           Text.Regex.TDFA+import           Text.Regex.TDFA.ByteString (compile)++-- | A URL and identifiers of those who provided that URL.+type UrlPair = (Text, [Identifier])++-- | Regular expression for matching HTTP/HTTPS URLs in chat text.+urlPattern :: Regex+Right urlPattern =+  compile+    defaultCompOpt+    defaultExecOpt{captureGroups=False}+    "https?://([[:alnum:]-]+\\.)*([[:alnum:]-]+)(:[[:digit:]]+)?(/[-0-9a-zA-Z$_.+!*'(),%?&=:@/;~#]*)?|\+    \<https?://[^>]*>|\+    \\\(https?://[^\\)]*\\)"++-- | Find all the URL matches using 'urlPattern' in a given 'Text' suitable+-- for being opened. Surrounding @<@ and @>@ are removed.+urlMatches :: LText.Text -> [Text]+urlMatches txt = removeBrackets . extractText . (^?! ix 0)+             <$> matchAll urlPattern (LText.unpack txt)+  where+    extractText (off,len) = LText.toStrict+                          $ LText.take (fromIntegral len)+                          $ LText.drop (fromIntegral off) txt++    removeBrackets t =+      case Text.uncons t of+       Just ('<',t') | not (Text.null t') -> Text.init t'+       Just ('(',t') | not (Text.null t') -> Text.init t'+       _                                  -> t++-- | Generate a list of URLs from the current focus and subfocus.+urlList :: ClientState -> [UrlPair]+urlList st = urlDedup $ urlListForFocus focus subfocus st+  where+    focus = view clientFocus st+    subfocus = view clientSubfocus st++urlListForFocus :: Focus -> Subfocus -> ClientState -> [UrlPair]+urlListForFocus focus subfocus st = case (netM, subfocus) of+  (Just cs, FocusChanList min' max') ->+    matchesTopic st min' max' cs+  (Just cs, FocusWho) ->+    matchesWhoReply st cs+  (_, _) ->+    toListOf (clientWindows . ix focus . winMessages . each . folding (matchesMsg st)) st+  where+    netM = do+      net <- focusNetwork focus+      view (clientConnections . at net) st++matchesMsg :: ClientState -> WindowLine -> [UrlPair]+matchesMsg st wl =+  [ (url, maybeToList $ views wlSummary summaryActor wl)+  | url <- concatMap urlMatches $ clientFilter st id [views wlText id wl]+  ]++matchesTopic :: ClientState -> Maybe Int -> Maybe Int -> NetworkState -> [UrlPair]+matchesTopic st min' max' cs =+  [ (url, [chan])+  | (chan, _, topic) <- clientFilterChannels st min' max' $ view (csChannelList . clsItems) cs+  , url <- urlMatches $ LText.fromStrict topic+  ]++matchesWhoReply :: ClientState -> NetworkState -> [UrlPair]+matchesWhoReply st cs =+  [ (url, [userNick $ view whoUserInfo wri])+  | wri <- clientFilter st whoFilterText $ view (csWhoReply . whoItems) cs+  , url <- urlMatches $ LText.fromStrict $ view whoRealname wri+  ]++-- | Deduplicates URLs, combining their identifiers while preserving order.+urlDedup :: [UrlPair] -> [UrlPair]+urlDedup pairs = rebuildList hmap [] pairs+  where+    rebuildList _     pairs' [] = reverse pairs'+    rebuildList hmap' pairs' ((url, _):rest)+      | HashMap.null hmap = reverse pairs'+      | otherwise = case ids of+        Just keys -> rebuildList hmapU ((url, reverse keys):pairs') rest+        Nothing -> rebuildList hmapU pairs' rest+      where+        (ids, hmapU) = HashMap.alterF (\v -> (v, Nothing)) url hmap'+    hmap = HashMap.fromListWith List.union pairs

src/Client/State/Window.hs view

@@ -23,7 +23,7 @@   , winMarker   , winHideMeta   , winHidden-  , winSilent+  , winActivityFilter    -- * Window lines   , WindowLines(..)@@ -37,7 +37,11 @@   , wlTimestamp    -- * Window line importance+  , ActivityFilter(..)   , WindowLineImportance(..)+  , activityFilterStrings+  , applyActivityFilter+  , readActivityFilter    -- * Window operations   , emptyWindow@@ -54,14 +58,15 @@   , unpackTimeOfDay   ) where -import           Client.Image.PackedImage-import           Client.Message-import           Control.Lens-import           Control.Monad ((<$!>))-import           Data.Text.Lazy (Text)-import           Data.Time-import           Data.Word-import           Data.Bits+import Client.Image.PackedImage (Image', imageText)+import Client.Message (IrcSummary)+import Control.Lens (Lens', view, to, from, non, set, makeLenses, Each(..), Getter)+import Control.Monad ((<$!>))+import Data.Bits ((.|.), (.&.), shiftL, shiftR)+import Data.Text.Lazy (Text)+import Data.Time+import Data.Word (Word64)+import Data.List (elemIndex)  -- | A single message to be displayed in a window. -- The normal message line consists of the image prefix@@ -94,7 +99,7 @@   , _winMention  :: !WindowLineImportance -- ^ Indicates an important event is unread   , _winHideMeta :: !Bool          -- ^ Hide metadata messages   , _winHidden   :: !Bool          -- ^ Remove from jump rotation-  , _winSilent   :: !Bool          -- ^ Ignore activity+  , _winActivityFilter :: !ActivityFilter -- ^ Filters for activity   }  data ActivityLevel = NoActivity | NormalActivity | HighActivity@@ -107,6 +112,33 @@   | WLImportant -- ^ Increment unread count and set important flag   deriving (Eq, Ord, Show, Read) +data ActivityFilter+  = AFSilent+  | AFQuieter+  | AFQuiet+  | AFImpOnly+  | AFLoud+  | AFLouder+  deriving (Eq, Ord, Enum)++activityFilterStrings :: [String]+activityFilterStrings = ["silent", "quieter", "quiet", "imponly", "loud", "louder"]++applyActivityFilter :: ActivityFilter -> WindowLineImportance -> WindowLineImportance+applyActivityFilter AFSilent  _           = WLBoring+applyActivityFilter AFQuieter WLNormal    = WLBoring+applyActivityFilter AFQuieter WLImportant = WLNormal+applyActivityFilter AFImpOnly WLNormal    = WLBoring+applyActivityFilter AFQuiet   WLImportant = WLNormal+applyActivityFilter AFLouder  WLNormal    = WLImportant+applyActivityFilter _ etc = etc++instance Show ActivityFilter where+  show af = activityFilterStrings !! fromEnum af++readActivityFilter :: String -> Maybe ActivityFilter+readActivityFilter s = toEnum <$> elemIndex s activityFilterStrings+ makeLenses ''Window makeLenses ''WindowLine @@ -127,7 +159,7 @@   , _winMention  = WLBoring   , _winHideMeta = False   , _winHidden   = False-  , _winSilent   = False+  , _winActivityFilter   = AFLoud   }  windowClear :: Window -> Window@@ -141,17 +173,23 @@  -- | Adds a given line to a window as the newest message. Window's -- unread count will be updated according to the given importance.-addToWindow :: WindowLine -> Window -> Window-addToWindow !msg !win = win-    { _winMessages = msg :- view winMessages win-    , _winTotal    = view winTotal win + 1-    , _winMarker   = (+1) <$!> view winMarker win-    , _winUnread   = if view wlImportance msg == WLBoring-                     then view winUnread win-                     else view winUnread win + 1-    , _winMention  = max (view winMention win) (view wlImportance msg)-    , _winHideMeta = view winHideMeta win-    }+-- Additionally returns True if this window becomes important as a result of this line.+addToWindow :: WindowLine -> Window -> (Window, Bool)+addToWindow !msg !win = (win', nowImportant)+    where+      win' = win+        { _winMessages = msg :- view winMessages win+        , _winTotal    = view winTotal win + 1+        , _winMarker   = (+1) <$!> view winMarker win+        , _winUnread   = if msgImportance == WLBoring+                         then view winUnread win+                         else view winUnread win + 1+        , _winMention  = max oldMention msgImportance+        , _winHideMeta = view winHideMeta win+        }+      oldMention = view winMention win+      nowImportant = oldMention < WLImportant && msgImportance >= WLImportant+      msgImportance = applyActivityFilter (view winActivityFilter win) (view wlImportance msg)  -- | Update the window clearing the unread count and important flag. windowSeen :: Window -> Window

src/Client/UserHost.hs view

@@ -17,8 +17,8 @@   , uhAccount   ) where -import           Control.Lens (makeLenses)-import           Data.Text (Text)+import Control.Lens (makeLenses)+import Data.Text (Text)  -- | Pair of username and hostname. Empty strings represent missing information. data UserAndHost = UserAndHost

src/Client/View.hs view

@@ -13,46 +13,56 @@   ( viewLines   ) where -import           Client.Image.PackedImage-import           Client.State-import           Client.State.Focus-import           Client.View.Cert-import           Client.View.ChannelInfo-import           Client.View.Digraphs-import           Client.View.Help-import           Client.View.IgnoreList-import           Client.View.KeyMap-import           Client.View.MaskList-import           Client.View.Mentions-import           Client.View.Messages-import           Client.View.Palette-import           Client.View.RtsStats-import           Client.View.UrlSelection-import           Client.View.UserList-import           Client.View.Windows-import           Control.Lens+import Client.Image.PackedImage (Image')+import Client.State+import Client.State.Focus+import Client.View.Cert (certViewLines)+import Client.View.ChannelList (channelListLines)+import Client.View.ChannelInfo (channelInfoImages)+import Client.View.Digraphs (digraphLines)+import Client.View.Help (helpImageLines)+import Client.View.IgnoreList (ignoreListLines)+import Client.View.KeyMap (keyMapLines)+import Client.View.MaskList (maskListImages)+import Client.View.Mentions (mentionsViewLines)+import Client.View.Messages (chatMessageImages)+import Client.View.Palette (paletteViewLines)+import Client.View.RtsStats (rtsStatsLines)+import Client.View.UrlSelection (urlSelectionView)+import Client.View.UserList (userInfoImages, userListImages)+import Client.View.Who (whoLines)+import Client.View.Windows (windowsImages)+import Control.Lens (view)  viewLines :: Focus -> Subfocus -> Int -> ClientState -> [Image'] viewLines focus subfocus w !st =-  case (focus, subfocus) of+  case (network', channel', subfocus) of     _ | Just ("url",arg) <- clientActiveCommand st ->       urlSelectionView w focus arg st-    (ChannelFocus network channel, FocusInfo) ->+    (Just network, Just channel, FocusInfo) ->       channelInfoImages network channel st-    (ChannelFocus network channel, FocusUsers)+    (Just network, Just channel, FocusUsers)       | view clientDetailView st -> userInfoImages network channel st       | otherwise                -> userListImages network channel w st-    (ChannelFocus network channel, FocusMasks mode) ->+    (Just network, Just channel, FocusMasks mode) ->       maskListImages mode network channel w st-    (_, FocusWindows filt) -> windowsImages filt st-    (_, FocusMentions)     -> mentionsViewLines w st-    (_, FocusPalette)      -> paletteViewLines pal-    (_, FocusDigraphs)     -> digraphLines w st-    (_, FocusKeyMap)       -> keyMapLines st-    (_, FocusHelp mb)      -> helpImageLines st mb pal-    (_, FocusRtsStats)     -> rtsStatsLines (view clientRtsStats st) pal-    (_, FocusIgnoreList)   -> ignoreListLines (view clientIgnores st) pal-    (_, FocusCert)         -> certViewLines st+    (_, _, FocusWindows filt) -> windowsImages filt st+    (_, _, FocusMentions)     -> mentionsViewLines w st+    (_, _, FocusPalette)      -> paletteViewLines pal+    (_, _, FocusDigraphs)     -> digraphLines w st+    (_, _, FocusKeyMap)       -> keyMapLines st+    (_, _, FocusHelp mb)      -> helpImageLines st mb pal+    (_, _, FocusRtsStats)     -> rtsStatsLines (view clientRtsStats st) pal+    (_, _, FocusIgnoreList)   -> ignoreListLines (view clientIgnores st) pal+    (_, _, FocusCert)         -> certViewLines st+    (Just network, _, FocusChanList min' max') ->+      channelListLines network w st (min', max')+    (Just network, _, FocusWho) ->+      whoLines network w st     _ -> chatMessageImages focus w st   where+    (network', channel') = case focus of+      Unfocused -> (Nothing, Nothing)+      NetworkFocus network -> (Just network, Nothing)+      ChannelFocus network channel -> (Just network, Just channel)     pal = clientPalette st

+ src/Client/View/ChannelList.hs view

@@ -0,0 +1,76 @@+{-# Language OverloadedStrings #-}+{-|+Module      : Client.View.ChannelList+Description : Line renderer for searchable channel lists+Copyright   : (c) TheDaemoness, 2023+License     : ISC+Maintainer  : emertens@gmail.com++This module renders the lines used in the channel user list.+-}+module Client.View.ChannelList ( channelListLines ) where++import           Client.Image.LineWrap (lineWrapPrefix)+import           Client.Image.Message (IdentifierColorMode(NormalIdentifier), coloredIdentifier)+import           Client.Image.PackedImage+import           Client.Image.Palette+import           Client.State+import           Client.State.Network+import           Control.Lens+import           Data.Text (Text)+import qualified Data.Text as Text+import           Graphics.Vty.Attributes (defAttr)+import           Irc.Identifier+import qualified Data.HashMap.Strict as HashMap+import Client.State.Focus (Subfocus(FocusChanList))++-- |+-- | Render the lines used by the @/list@ command in normal mode.+channelListLines ::+  Text        {- ^ network           -} ->+  Int         {- ^ window width      -} ->+  ClientState {- ^ client state      -} ->+  (Maybe Int, Maybe Int) {- ^ bounds -} ->+  [Image']+channelListLines network width st bounds =+  case preview (clientConnection network) st of+    Just cs -> channelListLines' cs width st bounds+    Nothing -> [text' (view palError pal) "No connection"]+  where+    pal = clientPalette st++channelListLines' ::+  NetworkState ->+  Int -> ClientState -> (Maybe Int, Maybe Int) -> [Image']+channelListLines' cs width st (min', max')+  | chanList^.clsDone = countImage <> queryPart : images+  | otherwise = countImagePending <> queryPart : images+  where+    chanList = cs^.csChannelList+    els = chanList^.clsElist+    pal = clientPalette st++    countImagePending = countImage <> text' (view palLabel pal) "..."+    countImage = text' (view palLabel pal) "Channels (visible/total): " <>+                 string defAttr (show (length entries')) <>+                 char (view palLabel pal) '/' <>+                 string defAttr (show (length entries))++    queryPart = mconcat $+      [text' (view palLabel pal) " More-than: " <> string defAttr (show lo) | FocusChanList (Just lo) _ <- [st^.clientSubfocus]] +++      [text' (view palLabel pal) " Less-than: " <> string defAttr (show hi) | FocusChanList _ (Just hi) <- [st^.clientSubfocus]] +++      [text' (view palLabel pal) " Elist: " <> text' defAttr txt | Just txt <- [els], not (Text.null txt)]++    entries = chanList^.clsItems+    entries' = clientFilterChannels st min' max' entries++    images = concatMap listItemImage entries'++    listItemImage :: (Identifier, Int, Text) -> [Image']+    listItemImage (chan, users, topic)+      | Text.null topic = [baseImage]+      | otherwise = reverse $ lineWrapPrefix width (baseImage <> label " topic:") (text' defAttr topic)+      where+        chanImage = coloredIdentifier pal NormalIdentifier HashMap.empty chan+        baseImage = chanImage <> label " users: " <> text' defAttr (Text.pack . show $ users)+        label = text' (view palLabel pal)

src/Client/View/Mentions.hs view

@@ -84,7 +84,7 @@   [ MentionLine       { mlTimestamp  = views wlTimestamp unpackUTCTime l       , mlFocus      = focus-      , mlImage      = case metadataImg (view wlSummary l) of+      , mlImage      = case metadataImg palette (view wlSummary l) of                          _ | detailed     -> [view wlFullImage l]                          Just (img, _, _) -> [img]                          Nothing          -> drawWindowLine palette w padAmt l

src/Client/View/Messages.hs view

@@ -28,7 +28,6 @@ import           Control.Lens import           Control.Monad import           Data.List-import           Graphics.Vty.Attributes import           Irc.Identifier import           Irc.Message import           Irc.UserInfo@@ -176,8 +175,10 @@         {- ^ Image, incoming identifier, outgoing identifier if changed -} metadataWindowLine st wl =   case view wlSummary wl of-    ChatSummary who -> (ignoreImage, userNick who, Nothing) <$ guard (identIgnored who st)-    summary         -> metadataImg summary+    ChatSummary who -> (ignoreImage pal, userNick who, Nothing) <$ guard (identIgnored who st)+    summary         -> metadataImg (clientPalette st) summary+  where+    pal = clientPalette st  bulkMetadata ::   ClientState ->@@ -187,8 +188,7 @@   | (quits, wls') <- span isMassQuit wls   , let n = length quits   , n > 10-  = Just (string (view palMeta pal) ("(split:" <> show n <> ")") <>-          char (withForeColor defAttr red) 'X', wls')+  = Just (string (view palPart pal) ("(split:" <> show n <> ")x"), wls')   where     pal = clientPalette st

src/Client/View/UrlSelection.hs view

@@ -19,18 +19,16 @@ import           Client.Image.PackedImage import           Client.Image.Palette import           Client.Image.LineWrap-import           Client.Message import           Client.State import           Client.State.Focus-import           Client.State.Window+import           Client.State.Url import           Control.Lens import           Data.HashMap.Strict (HashMap)-import           Data.Text (Text)+import           Data.List (intersperse, foldl1') import           Graphics.Vty.Attributes import           Irc.Identifier import           Text.Read (readMaybe) - -- | Generate the lines used for the view when typing @/url@ urlSelectionView ::   Int         {- ^ render width        -} ->@@ -40,12 +38,8 @@   [Image']    {- ^ image lines         -} urlSelectionView w focus arg st   = concat-  $ zipWith (draw w hilites pal padding selected) [1..] (toListOf urled st)+  $ zipWith (draw w hilites pal selected) [1..] (urlList st)   where-    urled = clientWindows . ix focus-          . winMessages   . each-          . folding matches-     focused = focus == view clientFocus st      selected@@ -55,33 +49,29 @@       | otherwise               = 0 -- won't match      cfg     = view clientConfig st-    padding = view configNickPadding cfg     pal     = view configPalette cfg      hilites = clientHighlightsFocus focus st --matches :: WindowLine -> [(Maybe Identifier, Text)]-matches wl = [ (views wlSummary summaryActor wl, url) | url <- views wlText urlMatches wl ]-- -- | Render one line of the url list draw ::   Int                       {- ^ rendered width            -} ->   HashMap Identifier Highlight {- ^ highlights             -} ->   Palette                   {- ^ palette                   -} ->-  PaddingMode               {- ^ nick render padding       -} ->   Int                       {- ^ selected index            -} ->   Int                       {- ^ url index                 -} ->-  (Maybe Identifier, Text)  {- ^ sender and url text       -} ->+  UrlPair                   {- ^ sender and url text       -} ->   [Image']                  {- ^ rendered lines            -}-draw w hilites pal padding selected i (who,url)+draw w hilites pal selected i (url, who)   = reverse   $ lineWrapPrefix w-      (string defAttr (shows i ". ") <>-       nickPad padding-         (foldMap (coloredIdentifier pal NormalIdentifier hilites) who) <> ": ")-      (text' attr (cleanText url))+      (string defAttr (shows i "."))+      (text' attr (cleanText url) <> who')   where+    who'+      | null who = mempty+      | otherwise = " (" <> imgIds <> ")"+    imgIds = foldl1' (<>) $ intersperse ", " $ map idImg who+    idImg id' = coloredIdentifier pal NormalIdentifier hilites id'     attr | selected == i = withStyle defAttr reverseVideo          | otherwise     = defAttr

+ src/Client/View/Who.hs view

@@ -0,0 +1,88 @@+{-# Language OverloadedStrings #-}+{-|+Module      : Client.View.Who+Description : Line renderer for /who replies+Copyright   : (c) TheDaemoness, 2023+License     : ISC+Maintainer  : emertens@gmail.com++This module renders the lines used in /who replies.+-}+module Client.View.Who ( whoLines ) where++import           Client.Image.LineWrap (lineWrapPrefix)+import           Client.Image.Message (IdentifierColorMode(NormalIdentifier), coloredIdentifier, coloredUserInfo, RenderMode (DetailedRender), prettyTime)+import           Client.Image.PackedImage+import           Client.Image.Palette+import           Client.State+import           Client.State.Network+import           Client.WhoReply+import           Control.Lens+import           Data.Text (Text)+import qualified Data.Text as Text+import           Graphics.Vty.Attributes (defAttr)+import           Irc.Identifier+import qualified Data.HashMap.Strict as HashMap+import Client.Image.MircFormatting (parseIrcText')+import Client.State.Focus (Focus(NetworkFocus))++-- |+-- | Render the lines used by the @/who@ command in normal mode.+whoLines ::+  Text        {- ^ network           -} ->+  Int         {- ^ window width      -} ->+  ClientState {- ^ client state      -} ->+  [Image']+whoLines network width st =+  -- TODO: This pattern exists in a few other views. Maybe deduplicate?+  case preview (clientConnection network) st of+    Just cs -> whoLines' cs width st+    Nothing -> [text' (view palError pal) "No connection"]+  where+    pal = clientPalette st++whoLines' :: NetworkState -> Int -> ClientState -> [Image']+whoLines' cs width st+  | Text.null $ view (csWhoReply . whoQuery . _1) cs = [text' (view palError pal) "No previous WHO query"]+  | whorpl^.whoDone = countImage <> queryPart : images+  | otherwise = countImagePending <> queryPart : images+  where+    pal = clientPalette st+    whorpl = view csWhoReply cs+    (query, arg) = view whoQuery whorpl+    entries = view whoItems whorpl+    entries' = clientFilter st whoFilterText entries++    images = concatMap renderEntry entries'+    renderEntry :: WhoReplyItem -> [Image']+    renderEntry entry = reverse $ lineWrapPrefix width (renderPrefix entry) (renderSuffix entry)+    -- Skipping rendering the channel because it doesn't add anything most of the time.+    renderPrefix entry = coloredUserInfo pal DetailedRender hilites (view whoUserInfo entry)+      where hilites = clientHighlightsFocus (NetworkFocus (view csNetwork cs)) st+    renderSuffix :: WhoReplyItem -> Image'+    renderSuffix entry = mconcat $ mapJoinWhoFields entry+      (const mempty)+      (label "$a:" . identifier)+      (label "ip: " . text' defAttr)+      (label "server: " . identifier)+      (label "away" $ text' defAttr "")+      (label "flags: " . text' (view palSigil pal))+      (label "hops: " . string defAttr . show)+      (label "idle: " . string defAttr . prettyTime 1)+      (label "oplvl: " . text' defAttr)+      (label "gecos: " . parseIrcText' False pal)++    countImagePending = countImage <> text' (view palLabel pal) "..."+    countImage = text' (view palLabel pal) "Users in " <>+                 coloredIdentifier pal NormalIdentifier HashMap.empty (mkId query) <>+                 text' (view palLabel pal) " (visible/total): " <>+                 string defAttr (show (length entries')) <>+                 char (view palLabel pal) '/' <>+                 string defAttr (show (length entries))+    queryPart = case arg of+      Just txt | not (Text.null txt) -> label " Options: " $ text' defAttr txt+      _ -> text' defAttr ""++    label txt image = text' (view palLabel pal) txt <> image <> text' defAttr " "+    -- Don't use hilites here; the identifiers are never the user's nick.+    identifier = coloredIdentifier pal NormalIdentifier HashMap.empty

src/Client/View/Windows.hs view

@@ -13,6 +13,7 @@   ( windowsImages   ) where +import           Client.Image.Message (coloredIdentifier, IdentifierColorMode (NormalIdentifier)) import           Client.Image.PackedImage import           Client.Image.Palette import           Client.State@@ -20,11 +21,11 @@ import           Client.State.Window import           Client.State.Network import           Control.Lens+import qualified Data.HashMap.Strict as HashMap import           Data.List import           Data.Maybe (fromMaybe) import qualified Data.Map as Map import           Graphics.Vty.Attributes-import           Irc.Identifier  -- | Draw the image lines associated with the @/windows@ command. windowsImages :: WindowsFilter -> ClientState -> [Image']@@ -92,13 +93,15 @@     ChannelFocus network channel ->       text' (view palLabel pal) network <>       char defAttr ':' <>-      text' (view palLabel pal) (idText channel)+      coloredIdentifier pal NormalIdentifier HashMap.empty channel  renderedWindowInfo :: Palette -> Window -> Image' renderedWindowInfo pal win =   string (view newMsgAttrLens pal) (views winUnread show win) <> "/" <>   string (view palActivity    pal) (views winTotal  show win) <>-  (if view winSilent win then text' (view palMeta pal) " silent" else mempty)+  case view winActivityFilter win of+    AFLoud -> mempty+    other -> string (view palMeta pal) (' ':show other)   where     newMsgAttrLens =       case view winMention win of

+ src/Client/WhoReply.hs view

@@ -0,0 +1,234 @@+{-# Language TemplateHaskell, OverloadedStrings, BangPatterns #-}++{-|+Module      : Client.WhoReply+Description : Parsed replies from WHO+Copyright   : (c) TheDaemoness, 2023+License     : ISC+Maintainer  : emertens@gmail.com++Because WHOX allows for a LOT of fiddliness regarding parameters,+this is extracted from Client.State.Network and given its own module.+-}++module Client.WhoReply+  ( WhoReply+  , WhoReplyItem+  , newWhoReply+  , finishWhoReply+  , recordWhoReply+  , recordWhoXReply+  , mapJoinWhoFields+  , whoFilterText+  +  -- Lenses+  , whoQuery+  , whoFields+  , whoToken+  , whoDone+  , whoItems+  , whoUserInfo+  , whoIp+  , whoServer+  , whoAway+  , whoMiscFlags+  , whoHops+  , whoIdleSecs+  , whoAcct+  , whoOpLvl+  , whoRealname+  ) where++import           Client.Image.Message (cleanText)+import           Control.Lens+import           Control.Lens.Unsound (lensProduct) -- Don't worry about it. Ctrl+F SOUNDNESS.+import           Data.List (sort)+import           Data.Set (Set)+import qualified Data.Set as Set+import           Data.Text (Text)+import qualified Data.Text as Text+import qualified Data.Text.Lazy as LText+import           Irc.Identifier+import           Irc.UserInfo+import           Text.Read (readMaybe)+  +data WhoReply = WhoReply+  { _whoQuery  :: !(Text, Maybe Text)+  , _whoFields :: !(Set Char)+  , _whoToken  :: !String+  , _whoDone   :: !Bool+  , _whoItems  :: ![WhoReplyItem]+  }++data WhoReplyItem = WhoReplyItem+  { _whoUserInfo  :: !UserInfo+  , _whoAcct      :: !Identifier+  , _whoIp        :: !Text -- We don't have iproute; (Maybe IP) would be nice here.+  , _whoServer    :: !Identifier+  , _whoAway      :: !(Maybe Bool)+  , _whoMiscFlags :: !Text+  , _whoHops      :: !(Maybe Int)+  , _whoIdleSecs  :: !String -- This can be a Maybe Int, but prettyTime takes a String.+  , _whoOpLvl     :: !Text+  , _whoRealname  :: !Text+  } deriving (Eq, Ord)++makeLenses ''WhoReply+makeLenses ''WhoReplyItem++newWhoReply :: Text -> String -> WhoReply+newWhoReply query "" = WhoReply+  { _whoQuery = (query, Nothing)+  , _whoToken = ""+  , _whoFields = Set.empty+  , _whoDone = False+  , _whoItems = []+  }+newWhoReply query ('%':arg) = WhoReply+  { _whoQuery = (query, Just $ Text.pack ('%':arg))+  , _whoToken = if Set.member 't' fieldSet then token' else ""+  , _whoFields = fieldSet+  , _whoDone = False+  , _whoItems = []+  }+  where+    fieldSet = Set.fromList fields+    (fields, token) = over _2 (drop 1) $ break (== ',') arg+    token' = if null token then "0" else token+newWhoReply query arg = WhoReply+  { _whoQuery = (query, Just $ Text.pack arg)+  , _whoToken = ""+  , _whoFields = Set.empty+  , _whoDone = False+  , _whoItems = []+  }++splitFlags :: String -> (Maybe Bool, Text)+splitFlags ('G':rest) = (Just True,  Text.pack rest)+splitFlags ('H':rest) = (Just False, Text.pack rest)+splitFlags rest       = (Nothing,    Text.pack rest)++newWhoReplyItem :: WhoReplyItem+newWhoReplyItem = WhoReplyItem+  { _whoUserInfo  = UserInfo+    { userNick = mkId ""+    , userName = ""+    , userHost = ""+    }+  , _whoAcct      = "0"+  , _whoIp        = "255.255.255.255"+  , _whoServer    = ""+  , _whoAway      = Nothing+  , _whoMiscFlags = ""+  , _whoHops      = Nothing+  , _whoIdleSecs  = ""+  , _whoOpLvl     = "n/a"+  , _whoRealname  = ""+  }++finishWhoReply :: WhoReply -> WhoReply+finishWhoReply wr = wr { _whoDone = True, _whoItems = reverse $ sort (_whoItems wr) }++recordWhoReply :: [Text] -> WhoReply -> WhoReply+recordWhoReply [_, _, uname, host, server, nick, flags, hcrn] reply+  | _whoDone reply = reply+  | otherwise = reply { _whoItems = wri:_whoItems reply}+  where+    wri = newWhoReplyItem+      { _whoUserInfo = UserInfo { userNick = mkId nick, userName = uname, userHost = host }+      , _whoServer = mkId server+      , _whoAway = away+      , _whoMiscFlags = miscFlags+      , _whoHops = readMaybe $ Text.unpack hops+      , _whoRealname = Text.stripStart realname+      }+    (hops, realname) = Text.break (== ' ') hcrn+    (away, miscFlags) = splitFlags $ Text.unpack flags+recordWhoReply _ reply = reply++-- | Field names for WHOX replies in order, excluding 't'.+whoXReplyFields :: [Char]+whoXReplyFields = "cuihsnfdlaor"++recordWhoXReply :: [Text] -> WhoReply -> WhoReply+recordWhoXReply []       reply = reply+recordWhoXReply (_:args) reply+  | _whoDone reply = reply+  | _whoToken reply == "" = withWri args+  | null args = reply+  | _whoToken reply == Text.unpack (head args) = withWri $ tail args+  | otherwise = reply+  where+    fields = filter ((flip Set.member) (_whoFields reply)) whoXReplyFields+    withWri args' = reply { _whoItems = recordWhoXReply' (zip args' fields) newWhoReplyItem:_whoItems reply}++recordWhoXReply' :: [(Text, Char)] -> WhoReplyItem -> WhoReplyItem+recordWhoXReply' [] = id+recordWhoXReply' ((arg, kind):rest) = recordWhoXReply' rest . updateFn+  where+    updateFn = case kind of+      'a' -> set whoAcct (mkId arg)+      -- Skip c+      'd' -> set whoHops (readMaybe $ Text.unpack arg)+      -- SOUNDNESS: whoAway and whoMiscFlags project disjoint parts of WhoReplyItem+      'f' -> set (lensProduct whoAway whoMiscFlags) flagsSplit+      'h' -> set (whoUserInfo . uiHost) arg+      'i' -> set whoIp arg+      'l' -> set whoIdleSecs (Text.unpack arg)+      'n' -> set (whoUserInfo . uiNick) (mkId arg)+      'o' -> set whoOpLvl arg+      'r' -> set whoRealname arg+      's' -> set whoServer (mkId arg)+      'u' -> set (whoUserInfo . uiName) arg+      _   -> id+    flagsSplit = splitFlags $ Text.unpack arg++-- Map non-default field values and join them into a list.+mapJoinWhoFields :: WhoReplyItem ->+  (UserInfo -> a) ->+  (Identifier -> a) ->+  (Text -> a) ->+  (Identifier -> a) ->+  a ->+  (Text -> a) ->+  (Int -> a) ->+  (String -> a) ->+  (Text -> a) ->+  (Text -> a) ->+  [a]+mapJoinWhoFields wri userinfo acct ip server away flags hops idle oplvl gecos = reverse $+  addFieldIf (require notNull . view whoRealname) gecos $+  addFieldIf (require (/= "n/a") . view whoOpLvl) oplvl $+  addFieldIf (require notNullOrZero . view whoIdleSecs) idle $+  addFieldIf (\n -> view whoHops n >>= require (> 0)) hops $+  addFieldIf (require notNull . view whoMiscFlags) flags $+  addFieldIf (\n -> view whoAway n >>= require id) (const away) $+  addFieldIf (require (notNull . idText) . view whoServer) server $+  addFieldIf (require (/= "255.255.255.255") . view whoIp) ip $+  addFieldIf (require (/= "0") . view whoAcct) acct+  [userinfo $ view whoUserInfo wri]+  where+    addFieldIf :: (WhoReplyItem -> Maybe a) -> (a -> b) -> [b] -> [b]+    addFieldIf getF mapF list = case getF wri of+      Just v -> mapF v:list+      Nothing -> list+    notNull = not . Text.null+    notNullOrZero ""  = False+    notNullOrZero "0" = False+    notNullOrZero _   = True+    require f v+      | f v = Just v+      | otherwise = Nothing++whoFilterText :: WhoReplyItem -> LText.Text+whoFilterText entry = LText.fromChunks $ concat $ mapJoinWhoFields entry+  (\x -> [renderUserInfo x])+  (\x -> [" $a:", idText x])+  (\x -> [" ip: ", x])+  (\x -> [" server: ", idText x])+  [" away"]+  (\x -> [" flags: ", x])+  (\x -> [" hops: ", Text.pack $ show x])+  (\x -> [" idle: ", Text.pack x])+  (\x -> [" oplvl: ", x])+  (\x -> [" gecos: ", cleanText x])

src/ContextFilter.hs view

@@ -1,40 +1,52 @@ module ContextFilter (filterContext) where +-- | Like 'filter' except you can request the elements before+-- and after the matched elements.+--+-- >>> filterContext 2 1 (\x -> 4<=x&&x<=6) [0..10::Int]+-- [2,3,4,5,6,7]+--+-- >>> filterContext 2 1 even [0..10::Int]+-- [0,1,2,3,4,5,6,7,8,9,10]+--+-- >>> filterContext 2 1 (==10) [0..10::Int]+-- [8,9,10]+--+-- >>> filterContext 2 1 (==0) [0..10::Int]+-- [0,1]+--+-- >>> filterContext 0 0 (==0) [0..10::Int]+-- [0]+--+-- >>> filterContext 2 1 (==5) [0..10::Int]+-- [3,4,5,6]+--+-- >>> filterContext 1 2 (==5) [0..10::Int]+-- [4,5,6,7] filterContext ::   Int         {- ^ context before       -} ->   Int         {- ^ context after        -} ->   (a -> Bool) {- ^ predicate            -} ->   [a]         {- ^ inputs               -} ->   [a]         {- ^ matches with context -}-filterContext before after p xs+filterContext before after p xs0   | before < 0 = error "filterContext: bad before"   | after  < 0 = error "filterContext: bad after"-  | otherwise  = selectList (dropSelection before selects) xs+  | otherwise  = go 0 0 xs0 xs0   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+    -- i: index+    -- m: current match window+    -- xs: list to match+    -- ys: offset list to generate results from+    go i m (x:xs) yys@(y:ys) =+      if (m > 0 || px) && i >= before then y : rest else rest+      where+        rest = go (i+1) m' xs ys'+        px = p x+        m' = max (m-1) (if px then width else 0)+        ys' = if i >= before then ys else yys -selectList :: Selection -> [a] -> [a]-selectList (Keep x) (y : ys) = y : selectList x ys-selectList (Skip x) (_ : ys) =     selectList x ys-selectList _        _        = []+    -- no more matches, so just return the remaining m window+    go _ m _ ys = take m ys

src/DigraphQuote.hs view

@@ -8,10 +8,10 @@ -} module DigraphQuote (digraphTable) where -import Data.Char-import Control.Monad-import Language.Haskell.TH-import Language.Haskell.TH.Quote+import Control.Monad ((<=<))+import Data.Char (chr)+import Language.Haskell.TH (Q, ExpQ, stringE)+import Language.Haskell.TH.Quote (QuasiQuoter(..)) import Numeric (readHex)  digraphTable :: QuasiQuoter

src/Digraphs.hs view

@@ -19,9 +19,9 @@   , digraphs   ) where -import           DigraphQuote-import           Data.Text (Text)-import qualified Data.Text as Text+import DigraphQuote (digraphTable)+import Data.Text (Text)+import Data.Text qualified as Text  -- | Two-character key for digraph lookup data Digraph = Digraph !Char !Char

src/LensUtils.hs view

@@ -20,9 +20,9 @@   , localTimeDay   ) where -import           Control.Lens-import           Data.Time-import           StrictUnit+import Control.Lens (Lens', (??), set, ASetter, LensLike)+import Data.Time (ZonedTime(ZonedTime), LocalTime(LocalTime), Day, TimeOfDay)+import StrictUnit (StrictUnit(..))  -- | Modify the target of a 'Setter' with a function. The result -- is strict in the results of applying the function. Strict version

src/RtsStats.hs view

@@ -15,13 +15,13 @@   , statsToEntries   ) where -import           Data.Int        (Int64)-import           Data.List       (intercalate)-import           Data.List.Split (chunksOf)-import           Data.Text       (Text)-import qualified Data.Text as Text-import           Data.Word       (Word32, Word64)-import           GHC.Stats+import Data.Int        (Int64)+import Data.List       (intercalate)+import Data.List.Split (chunksOf)+import Data.Text       (Text)+import Data.Text qualified as Text+import Data.Word       (Word32, Word64)+import GHC.Stats  class    Render a      where render :: a -> Text instance Render Word32 where render = prettyNum

src/StrQuote.hs view

@@ -8,8 +8,8 @@ -} module StrQuote (str) where -import Language.Haskell.TH-import Language.Haskell.TH.Quote+import Language.Haskell.TH (Pat(LitP), Type(LitT), stringE, Lit(StringL), TyLit(StrTyLit))+import Language.Haskell.TH.Quote (QuasiQuoter(..))  str :: QuasiQuoter str = QuasiQuoter

src/StrictUnit.hs view

@@ -15,7 +15,7 @@   ( StrictUnit(..)   ) where -import           Data.Semigroup (stimes, stimesIdempotent)+import Data.Semigroup (stimes, stimesIdempotent)  -- | Unit data type with a strict 'Semigroup' and 'Monoid' instances. data StrictUnit = StrictUnit