diff --git a/ChangeLog.md b/ChangeLog.md --- a/ChangeLog.md +++ b/ChangeLog.md @@ -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 diff --git a/README.md b/README.md --- a/README.md +++ b/README.md @@ -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) | diff --git a/Setup.hs b/Setup.hs --- a/Setup.hs +++ b/Setup.hs @@ -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" diff --git a/exec/Exports.hs b/exec/Exports.hs --- a/exec/Exports.hs +++ b/exec/Exports.hs @@ -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 diff --git a/exec/Main.hs b/exec/Main.hs --- a/exec/Main.hs +++ b/exec/Main.hs @@ -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 diff --git a/glirc.cabal b/glirc.cabal --- a/glirc.cabal +++ b/glirc.cabal @@ -1,6 +1,6 @@ cabal-version: 2.2 name: glirc -version: 2.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 diff --git a/src/Client/Authentication/Ecdh.hs b/src/Client/Authentication/Ecdh.hs --- a/src/Client/Authentication/Ecdh.hs +++ b/src/Client/Authentication/Ecdh.hs @@ -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 diff --git a/src/Client/Authentication/Ecdsa.hs b/src/Client/Authentication/Ecdsa.hs --- a/src/Client/Authentication/Ecdsa.hs +++ b/src/Client/Authentication/Ecdsa.hs @@ -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" diff --git a/src/Client/Authentication/Scram.hs b/src/Client/Authentication/Scram.hs --- a/src/Client/Authentication/Scram.hs +++ b/src/Client/Authentication/Scram.hs @@ -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 diff --git a/src/Client/CApi.hs b/src/Client/CApi.hs --- a/src/Client/CApi.hs +++ b/src/Client/CApi.hs @@ -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) ------------------------------------------------------------------------ diff --git a/src/Client/CApi/Exports.hs b/src/Client/CApi/Exports.hs --- a/src/Client/CApi/Exports.hs +++ b/src/Client/CApi/Exports.hs @@ -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) ------------------------------------------------------------------------ diff --git a/src/Client/CApi/Types.hsc b/src/Client/CApi/Types.hsc --- a/src/Client/CApi/Types.hsc +++ b/src/Client/CApi/Types.hsc @@ -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'. diff --git a/src/Client/Commands.hs b/src/Client/Commands.hs --- a/src/Client/Commands.hs +++ b/src/Client/Commands.hs @@ -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 diff --git a/src/Client/Commands/Arguments/Parser.hs b/src/Client/Commands/Arguments/Parser.hs --- a/src/Client/Commands/Arguments/Parser.hs +++ b/src/Client/Commands/Arguments/Parser.hs @@ -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 = diff --git a/src/Client/Commands/Arguments/Renderer.hs b/src/Client/Commands/Arguments/Renderer.hs --- a/src/Client/Commands/Arguments/Renderer.hs +++ b/src/Client/Commands/Arguments/Renderer.hs @@ -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 -} -> diff --git a/src/Client/Commands/Arguments/Spec.hs b/src/Client/Commands/Arguments/Spec.hs --- a/src/Client/Commands/Arguments/Spec.hs +++ b/src/Client/Commands/Arguments/Spec.hs @@ -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 diff --git a/src/Client/Commands/Certificate.hs b/src/Client/Commands/Certificate.hs --- a/src/Client/Commands/Certificate.hs +++ b/src/Client/Commands/Certificate.hs @@ -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") "" diff --git a/src/Client/Commands/Channel.hs b/src/Client/Commands/Channel.hs --- a/src/Client/Commands/Channel.hs +++ b/src/Client/Commands/Channel.hs @@ -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 = diff --git a/src/Client/Commands/Chat.hs b/src/Client/Commands/Chat.hs --- a/src/Client/Commands/Chat.hs +++ b/src/Client/Commands/Chat.hs @@ -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" diff --git a/src/Client/Commands/Connection.hs b/src/Client/Commands/Connection.hs --- a/src/Client/Commands/Connection.hs +++ b/src/Client/Commands/Connection.hs @@ -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" diff --git a/src/Client/Commands/Exec.hs b/src/Client/Commands/Exec.hs --- a/src/Client/Commands/Exec.hs +++ b/src/Client/Commands/Exec.hs @@ -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 diff --git a/src/Client/Commands/Interpolation.hs b/src/Client/Commands/Interpolation.hs --- a/src/Client/Commands/Interpolation.hs +++ b/src/Client/Commands/Interpolation.hs @@ -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 diff --git a/src/Client/Commands/Operator.hs b/src/Client/Commands/Operator.hs --- a/src/Client/Commands/Operator.hs +++ b/src/Client/Commands/Operator.hs @@ -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" diff --git a/src/Client/Commands/Queries.hs b/src/Client/Commands/Queries.hs --- a/src/Client/Commands/Queries.hs +++ b/src/Client/Commands/Queries.hs @@ -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\ + \ 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 = diff --git a/src/Client/Commands/Recognizer.hs b/src/Client/Commands/Recognizer.hs --- a/src/Client/Commands/Recognizer.hs +++ b/src/Client/Commands/Recognizer.hs @@ -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 diff --git a/src/Client/Commands/TabCompletion.hs b/src/Client/Commands/TabCompletion.hs --- a/src/Client/Commands/TabCompletion.hs +++ b/src/Client/Commands/TabCompletion.hs @@ -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 diff --git a/src/Client/Commands/Toggles.hs b/src/Client/Commands/Toggles.hs --- a/src/Client/Commands/Toggles.hs +++ b/src/Client/Commands/Toggles.hs @@ -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" diff --git a/src/Client/Commands/Types.hs b/src/Client/Commands/Types.hs --- a/src/Client/Commands/Types.hs +++ b/src/Client/Commands/Types.hs @@ -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 diff --git a/src/Client/Commands/Window.hs b/src/Client/Commands/Window.hs --- a/src/Client/Commands/Window.hs +++ b/src/Client/Commands/Window.hs @@ -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 diff --git a/src/Client/Commands/WordCompletion.hs b/src/Client/Commands/WordCompletion.hs --- a/src/Client/Commands/WordCompletion.hs +++ b/src/Client/Commands/WordCompletion.hs @@ -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 diff --git a/src/Client/Commands/ZNC.hs b/src/Client/Commands/ZNC.hs --- a/src/Client/Commands/ZNC.hs +++ b/src/Client/Commands/ZNC.hs @@ -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" diff --git a/src/Client/Configuration.hs b/src/Client/Configuration.hs --- a/src/Client/Configuration.hs +++ b/src/Client/Configuration.hs @@ -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 diff --git a/src/Client/Configuration/Colors.hs b/src/Client/Configuration/Colors.hs --- a/src/Client/Configuration/Colors.hs +++ b/src/Client/Configuration/Colors.hs @@ -1,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" diff --git a/src/Client/Configuration/Macros.hs b/src/Client/Configuration/Macros.hs --- a/src/Client/Configuration/Macros.hs +++ b/src/Client/Configuration/Macros.hs @@ -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 diff --git a/src/Client/Configuration/Notifications.hs b/src/Client/Configuration/Notifications.hs new file mode 100644 --- /dev/null +++ b/src/Client/Configuration/Notifications.hs @@ -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 diff --git a/src/Client/Configuration/ServerSettings.hs b/src/Client/Configuration/ServerSettings.hs --- a/src/Client/Configuration/ServerSettings.hs +++ b/src/Client/Configuration/ServerSettings.hs @@ -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] diff --git a/src/Client/Configuration/Sts.hs b/src/Client/Configuration/Sts.hs --- a/src/Client/Configuration/Sts.hs +++ b/src/Client/Configuration/Sts.hs @@ -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 diff --git a/src/Client/EventLoop.hs b/src/Client/EventLoop.hs --- a/src/Client/EventLoop.hs +++ b/src/Client/EventLoop.hs @@ -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) diff --git a/src/Client/EventLoop/Actions.hs b/src/Client/EventLoop/Actions.hs --- a/src/Client/EventLoop/Actions.hs +++ b/src/Client/EventLoop/Actions.hs @@ -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 diff --git a/src/Client/EventLoop/Errors.hs b/src/Client/EventLoop/Errors.hs --- a/src/Client/EventLoop/Errors.hs +++ b/src/Client/EventLoop/Errors.hs @@ -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 :: diff --git a/src/Client/EventLoop/Network.hs b/src/Client/EventLoop/Network.hs --- a/src/Client/EventLoop/Network.hs +++ b/src/Client/EventLoop/Network.hs @@ -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 diff --git a/src/Client/Hook.hs b/src/Client/Hook.hs --- a/src/Client/Hook.hs +++ b/src/Client/Hook.hs @@ -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'), diff --git a/src/Client/Hook/DroneBLRelay.hs b/src/Client/Hook/DroneBLRelay.hs --- a/src/Client/Hook/DroneBLRelay.hs +++ b/src/Client/Hook/DroneBLRelay.hs @@ -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. diff --git a/src/Client/Hook/Matterbridge.hs b/src/Client/Hook/Matterbridge.hs --- a/src/Client/Hook/Matterbridge.hs +++ b/src/Client/Hook/Matterbridge.hs @@ -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 diff --git a/src/Client/Hook/Snotice.hs b/src/Client/Hook/Snotice.hs --- a/src/Client/Hook/Snotice.hs +++ b/src/Client/Hook/Snotice.hs @@ -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|]), diff --git a/src/Client/Hook/Znc/Buffextras.hs b/src/Client/Hook/Znc/Buffextras.hs --- a/src/Client/Hook/Znc/Buffextras.hs +++ b/src/Client/Hook/Znc/Buffextras.hs @@ -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 diff --git a/src/Client/Hooks.hs b/src/Client/Hooks.hs --- a/src/Client/Hooks.hs +++ b/src/Client/Hooks.hs @@ -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) diff --git a/src/Client/Image.hs b/src/Client/Image.hs --- a/src/Client/Image.hs +++ b/src/Client/Image.hs @@ -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. diff --git a/src/Client/Image/Layout.hs b/src/Client/Image/Layout.hs --- a/src/Client/Image/Layout.hs +++ b/src/Client/Image/Layout.hs @@ -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 :: diff --git a/src/Client/Image/LineWrap.hs b/src/Client/Image/LineWrap.hs --- a/src/Client/Image/LineWrap.hs +++ b/src/Client/Image/LineWrap.hs @@ -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 diff --git a/src/Client/Image/Message.hs b/src/Client/Image/Message.hs --- a/src/Client/Image/Message.hs +++ b/src/Client/Image/Message.hs @@ -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) diff --git a/src/Client/Image/MircFormatting.hs b/src/Client/Image/MircFormatting.hs --- a/src/Client/Image/MircFormatting.hs +++ b/src/Client/Image/MircFormatting.hs @@ -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 diff --git a/src/Client/Image/PackedImage.hs b/src/Client/Image/PackedImage.hs --- a/src/Client/Image/PackedImage.hs +++ b/src/Client/Image/PackedImage.hs @@ -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 diff --git a/src/Client/Image/Palette.hs b/src/Client/Image/Palette.hs --- a/src/Client/Image/Palette.hs +++ b/src/Client/Image/Palette.hs @@ -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) ] diff --git a/src/Client/Image/StatusLine.hs b/src/Client/Image/StatusLine.hs --- a/src/Client/Image/StatusLine.hs +++ b/src/Client/Image/StatusLine.hs @@ -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 ':' diff --git a/src/Client/Image/Textbox.hs b/src/Client/Image/Textbox.hs --- a/src/Client/Image/Textbox.hs +++ b/src/Client/Image/Textbox.hs @@ -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 = diff --git a/src/Client/Log.hs b/src/Client/Log.hs --- a/src/Client/Log.hs +++ b/src/Client/Log.hs @@ -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 diff --git a/src/Client/Mask.hs b/src/Client/Mask.hs --- a/src/Client/Mask.hs +++ b/src/Client/Mask.hs @@ -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 diff --git a/src/Client/Message.hs b/src/Client/Message.hs --- a/src/Client/Message.hs +++ b/src/Client/Message.hs @@ -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 - diff --git a/src/Client/Network/Async.hs b/src/Client/Network/Async.hs --- a/src/Client/Network/Async.hs +++ b/src/Client/Network/Async.hs @@ -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 diff --git a/src/Client/Network/Connect.hs b/src/Client/Network/Connect.hs --- a/src/Client/Network/Connect.hs +++ b/src/Client/Network/Connect.hs @@ -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 diff --git a/src/Client/Options.hs b/src/Client/Options.hs --- a/src/Client/Options.hs +++ b/src/Client/Options.hs @@ -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 diff --git a/src/Client/State.hs b/src/Client/State.hs --- a/src/Client/State.hs +++ b/src/Client/State.hs @@ -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?://[^\\)]*\\)" - - --- | 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 diff --git a/src/Client/State/Channel.hs b/src/Client/State/Channel.hs --- a/src/Client/State/Channel.hs +++ b/src/Client/State/Channel.hs @@ -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 diff --git a/src/Client/State/EditBox.hs b/src/Client/State/EditBox.hs --- a/src/Client/State/EditBox.hs +++ b/src/Client/State/EditBox.hs @@ -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 diff --git a/src/Client/State/EditBox/Content.hs b/src/Client/State/EditBox/Content.hs --- a/src/Client/State/EditBox/Content.hs +++ b/src/Client/State/EditBox/Content.hs @@ -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 diff --git a/src/Client/State/Extensions.hs b/src/Client/State/Extensions.hs --- a/src/Client/State/Extensions.hs +++ b/src/Client/State/Extensions.hs @@ -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 :: diff --git a/src/Client/State/Focus.hs b/src/Client/State/Focus.hs --- a/src/Client/State/Focus.hs +++ b/src/Client/State/Focus.hs @@ -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. diff --git a/src/Client/State/Network.hs b/src/Client/State/Network.hs --- a/src/Client/State/Network.hs +++ b/src/Client/State/Network.hs @@ -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. diff --git a/src/Client/State/Url.hs b/src/Client/State/Url.hs new file mode 100644 --- /dev/null +++ b/src/Client/State/Url.hs @@ -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?://[^\\)]*\\)" + +-- | 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 diff --git a/src/Client/State/Window.hs b/src/Client/State/Window.hs --- a/src/Client/State/Window.hs +++ b/src/Client/State/Window.hs @@ -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 diff --git a/src/Client/UserHost.hs b/src/Client/UserHost.hs --- a/src/Client/UserHost.hs +++ b/src/Client/UserHost.hs @@ -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 diff --git a/src/Client/View.hs b/src/Client/View.hs --- a/src/Client/View.hs +++ b/src/Client/View.hs @@ -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 diff --git a/src/Client/View/ChannelList.hs b/src/Client/View/ChannelList.hs new file mode 100644 --- /dev/null +++ b/src/Client/View/ChannelList.hs @@ -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) diff --git a/src/Client/View/Mentions.hs b/src/Client/View/Mentions.hs --- a/src/Client/View/Mentions.hs +++ b/src/Client/View/Mentions.hs @@ -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 diff --git a/src/Client/View/Messages.hs b/src/Client/View/Messages.hs --- a/src/Client/View/Messages.hs +++ b/src/Client/View/Messages.hs @@ -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 diff --git a/src/Client/View/UrlSelection.hs b/src/Client/View/UrlSelection.hs --- a/src/Client/View/UrlSelection.hs +++ b/src/Client/View/UrlSelection.hs @@ -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 diff --git a/src/Client/View/Who.hs b/src/Client/View/Who.hs new file mode 100644 --- /dev/null +++ b/src/Client/View/Who.hs @@ -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 diff --git a/src/Client/View/Windows.hs b/src/Client/View/Windows.hs --- a/src/Client/View/Windows.hs +++ b/src/Client/View/Windows.hs @@ -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 diff --git a/src/Client/WhoReply.hs b/src/Client/WhoReply.hs new file mode 100644 --- /dev/null +++ b/src/Client/WhoReply.hs @@ -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]) diff --git a/src/ContextFilter.hs b/src/ContextFilter.hs --- a/src/ContextFilter.hs +++ b/src/ContextFilter.hs @@ -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 diff --git a/src/DigraphQuote.hs b/src/DigraphQuote.hs --- a/src/DigraphQuote.hs +++ b/src/DigraphQuote.hs @@ -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 diff --git a/src/Digraphs.hs b/src/Digraphs.hs --- a/src/Digraphs.hs +++ b/src/Digraphs.hs @@ -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 diff --git a/src/LensUtils.hs b/src/LensUtils.hs --- a/src/LensUtils.hs +++ b/src/LensUtils.hs @@ -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 diff --git a/src/RtsStats.hs b/src/RtsStats.hs --- a/src/RtsStats.hs +++ b/src/RtsStats.hs @@ -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 diff --git a/src/StrQuote.hs b/src/StrQuote.hs --- a/src/StrQuote.hs +++ b/src/StrQuote.hs @@ -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 diff --git a/src/StrictUnit.hs b/src/StrictUnit.hs --- a/src/StrictUnit.hs +++ b/src/StrictUnit.hs @@ -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