diff --git a/ChangeLog.md b/ChangeLog.md --- a/ChangeLog.md +++ b/ChangeLog.md @@ -1,5 +1,14 @@ # Revision history for glirc +## 2.39 + +* Extra oper commands and reply parsing +* Account tracking with account-tags +* Added matterbridge hook +* Support SASL SCRAM +* Add locked editor mode (F7) +* Add `tls-verify` to specify expected certificate hostname + ## 2.38 * Avoid ping timeout disconnects while other packets are still arriving @@ -262,7 +271,7 @@ ## 2.18 * Add digraph support under `M-k` and `/digraphs` -* Add ECDSA-NIST256P-CHALLENGE support for Freenode via Tor +* Add ECDSA-NIST256P-CHALLENGE support * Load mask list on `/masks` * Add `C-x` to change to next network window * Allow `/clear NETWORK *` to clear all windows for the given network @@ -395,7 +404,7 @@ ## 2.1 * Add red highlighting for own nick -* Synchronize reply codes with Freenode +* Synchronize reply codes with ircd-seven * Add textual interpretation of reply codes * Add SASL support * Add `/channelinfo` command diff --git a/README.md b/README.md --- a/README.md +++ b/README.md @@ -98,13 +98,11 @@ tls: yes -- or: no, or: starttls -- enabling tls automatically uses port 6697 tls-verify: yes -- or: no - tls-client-cert: "/path/to/cert.pem" - tls-client-key: "/path/to/cert.key" -- Override the defaults when connecting to specific servers servers: - * name: "fn" - hostname: "chat.freenode.net" + * name: "libera" + hostname: "irc.libera.chat" sasl: username: "someuser" password: "somepass" @@ -145,7 +143,6 @@ width: 13 url-opener: "open" -- This works on macOS, "gnome-open" for GNOME -download-dir: "~/Downloads" -- defaults to HOME key-bindings: * bind: "C-M-b" @@ -182,7 +179,6 @@ | `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 | -| `download-dir` | text | path to the directory where to place DCC downloads, defaults to HOME | | `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) | @@ -298,7 +294,6 @@ * `/extension ` - Send the given params to the named extension * `/exec [-n network] [-c channel] ` - Execute a command, If no network or channel are provided send output to client window, if network and channel are provided send output as messages, if network is provided send output as raw IRC messages. * `/url [n]` - Execute url-opener on the nth URL in the current window (defaults to first) -* `/dcc [(accept|resume|cancel|clear)] [n]` - Execute the corresponding action on the nth offer. View toggles * `/toggle-detail` - toggle full detail view of messages @@ -463,12 +458,10 @@ * `network` - current network name * `nick` - current nickname -The arguments to a command will be mapped to integer indexes. The command -itself is at index zero. +The arguments to a command will be mapped to integer indexes. -* `0` - command -* `1` - first argument -* `2` - second argument (etc.) +* `0` - first argument +* `1` - second argument (etc.) Hooks ===== diff --git a/glirc.1 b/glirc.1 --- a/glirc.1 +++ b/glirc.1 @@ -56,8 +56,8 @@ tls: yes servers: - * name: "freenode" - hostname: "chat.freenode.net" + * name: "libera" + hostname: "irc.libera.chat" * name: "oftc" hostname: "irc.oftc.net" 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.38 +version: 2.39 synopsis: Console IRC client description: Console IRC client . @@ -23,7 +23,7 @@ tested-with: GHC==8.6.5 custom-setup - setup-depends: base >=4.12 && <4.16, + setup-depends: base >=4.12 && <4.17, filepath >=1.4 && <1.5, Cabal >=2.2 && <4 @@ -44,9 +44,9 @@ build-depends: base, glirc, lens, text, vty if os(Linux) - ld-options: -Wl,--dynamic-list=exec/linux_exported_symbols.txt + ld-options: -Wl,--dynamic-list=exec/linux_exported_symbols.txt if os(Darwin) - ld-options: -Wl,-exported_symbols_list,exec/macos_exported_symbols.txt + ld-options: -Wl,-exported_symbols_list,exec/macos_exported_symbols.txt library ghc-options: -Wall -O2 @@ -57,129 +57,137 @@ default-language: Haskell2010 build-tool-depends: hsc2hs:hsc2hs - exposed-modules: Client.Authentication.Ecdsa - Client.CApi - Client.CApi.Exports - Client.CApi.Types - Client.Commands - Client.Commands.Arguments.Parser - Client.Commands.Arguments.Renderer - Client.Commands.Arguments.Spec - Client.Commands.Channel - Client.Commands.Chat - Client.Commands.Certificate - Client.Commands.Connection - Client.Commands.Exec - Client.Commands.Interpolation - Client.Commands.Operator - Client.Commands.Queries - Client.Commands.Recognizer - Client.Commands.TabCompletion - Client.Commands.Toggles - Client.Commands.Types - Client.Commands.Window - Client.Commands.WordCompletion - Client.Commands.ZNC - Client.Configuration - Client.Configuration.Colors - Client.Configuration.Macros - Client.Configuration.ServerSettings - Client.Configuration.Sts - Client.EventLoop - Client.EventLoop.Actions - Client.EventLoop.Errors - Client.EventLoop.Network - Client.Hook - Client.Hook.FreRelay - Client.Hook.Snotice - Client.Hook.Znc.Buffextras - Client.Hooks - Client.Image - Client.Image.Layout - Client.Image.LineWrap - Client.Image.Message - Client.Image.MircFormatting - Client.Image.PackedImage - Client.Image.Palette - Client.Image.StatusLine - Client.Image.Textbox - Client.Log - Client.Mask - Client.Message - Client.Network.Async - Client.Network.Connect - Client.Options - Client.State - Client.State.Channel - Client.State.EditBox - Client.State.EditBox.Content - Client.State.Extensions - Client.State.Focus - Client.State.Network - Client.State.Window - Client.UserHost - Client.View - Client.View.Cert - Client.View.ChannelInfo - Client.View.Digraphs - Client.View.Help - Client.View.IgnoreList - Client.View.KeyMap - Client.View.MaskList - Client.View.Mentions - Client.View.Messages - Client.View.Palette - Client.View.RtsStats - Client.View.UrlSelection - Client.View.UserList - Client.View.Windows + exposed-modules: + Client.Authentication.Ecdsa + Client.Authentication.Ecdh + Client.Authentication.Scram + Client.CApi + Client.CApi.Exports + Client.CApi.Types + Client.Commands + Client.Commands.Arguments.Parser + Client.Commands.Arguments.Renderer + Client.Commands.Arguments.Spec + Client.Commands.Channel + Client.Commands.Chat + Client.Commands.Certificate + Client.Commands.Connection + Client.Commands.Exec + Client.Commands.Interpolation + Client.Commands.Operator + Client.Commands.Queries + Client.Commands.Recognizer + Client.Commands.TabCompletion + Client.Commands.Toggles + Client.Commands.Types + Client.Commands.Window + Client.Commands.WordCompletion + Client.Commands.ZNC + Client.Configuration + Client.Configuration.Colors + Client.Configuration.Macros + Client.Configuration.ServerSettings + Client.Configuration.Sts + Client.EventLoop + Client.EventLoop.Actions + Client.EventLoop.Errors + Client.EventLoop.Network + Client.Hook + Client.Hook.DroneBLRelay + Client.Hook.Matterbridge + Client.Hook.Snotice + Client.Hook.Znc.Buffextras + Client.Hooks + Client.Image + Client.Image.Layout + Client.Image.LineWrap + Client.Image.Message + Client.Image.MircFormatting + Client.Image.PackedImage + Client.Image.Palette + Client.Image.StatusLine + Client.Image.Textbox + Client.Log + Client.Mask + Client.Message + Client.Network.Async + Client.Network.Connect + Client.Options + Client.State + Client.State.Channel + Client.State.EditBox + Client.State.EditBox.Content + Client.State.Extensions + Client.State.Focus + Client.State.Network + Client.State.Window + Client.UserHost + Client.View + Client.View.Cert + Client.View.ChannelInfo + Client.View.Digraphs + Client.View.Help + Client.View.IgnoreList + Client.View.KeyMap + Client.View.MaskList + Client.View.Mentions + Client.View.Messages + Client.View.Palette + Client.View.RtsStats + Client.View.UrlSelection + Client.View.UserList + Client.View.Windows - other-modules: ContextFilter - DigraphQuote - Digraphs - LensUtils - RtsStats - StrQuote - StrictUnit - Paths_glirc - Build_glirc + other-modules: + ContextFilter + DigraphQuote + Digraphs + LensUtils + RtsStats + StrQuote + StrictUnit + Paths_glirc + Build_glirc - autogen-modules: Paths_glirc - Build_glirc + autogen-modules: + Paths_glirc + Build_glirc - build-depends: base >=4.11 && <4.16, - HsOpenSSL >=0.11 && <0.12, - async >=2.2 && <2.3, - attoparsec >=0.13 && <0.14, - base64-bytestring >=1.0.0.1&& <1.3, - bytestring >=0.10.8 && <0.12, - config-schema ^>=1.2.1.0, - config-value ^>=0.8, - containers >=0.5.7 && <0.7, - directory >=1.2.6 && <1.4, - filepath >=1.4.1 && <1.5, - free >=4.12 && <5.2, - gitrev >=1.2 && <1.4, - hashable >=1.2.4 && <1.4, - hookup ^>=0.6, - irc-core ^>=2.10, - kan-extensions >=5.0 && <5.3, - lens >=4.14 && <5.1, - random >=1.1 && <1.3, - network >=2.6.2 && <3.2, - process >=1.4.2 && <1.7, - psqueues >=0.2.7 && <0.3, - regex-tdfa >=1.3.1 && <1.4, - split >=0.2 && <0.3, - stm >=2.4 && <2.6, - template-haskell >=2.11 && <2.18, - text >=1.2.2 && <1.3, - time >=1.6 && <1.12, - transformers >=0.5.2 && <0.6, - unix >=2.7 && <2.8, - unordered-containers >=0.2.7 && <0.3, - vector >=0.11 && <0.13, - vty >=5.31 && <5.34 + build-depends: + base >=4.11 && <4.17, + 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, + config-value ^>=0.8, + containers >=0.5.7 && <0.7, + curve25519 ^>=0.2.5, + directory >=1.2.6 && <1.4, + filepath >=1.4.1 && <1.5, + free >=4.12 && <5.2, + githash ^>=0.1.6, + hashable >=1.2.4 && <1.5, + hookup ^>=0.7, + irc-core ^>=2.10, + kan-extensions >=5.0 && <5.3, + lens >=4.14 && <5.2, + random >=1.1 && <1.3, + network >=2.6.2 && <3.2, + process >=1.4.2 && <1.7, + psqueues >=0.2.7 && <0.3, + regex-tdfa >=1.3.1 && <1.4, + 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, + transformers >=0.5.2 && <0.7, + unix >=2.7 && <2.8, + unordered-containers >=0.2.11 && <0.3, + vector >=0.11 && <0.13, + vty >=5.35 && <5.36, test-suite test type: exitcode-stdio-1.0 diff --git a/src/Client/Authentication/Ecdh.hs b/src/Client/Authentication/Ecdh.hs new file mode 100644 --- /dev/null +++ b/src/Client/Authentication/Ecdh.hs @@ -0,0 +1,61 @@ +{-# Language OverloadedStrings, ImportQualifiedPost #-} +module Client.Authentication.Ecdh + ( + -- * Phase type + Phase1, + -- * Mechanism details + mechanismName, + -- * Transition functions + clientFirst, + clientResponse, + ) where + +import Control.Monad (guard) +import Crypto.Curve25519.Pure qualified as Curve +import Data.Bits (xor) +import Data.ByteString (ByteString) +import Data.ByteString qualified as B +import Data.ByteString.Base64 qualified as B64 +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 ) + +newtype Phase1 = Phase1 Curve.PrivateKey + +mechanismName :: Text +mechanismName = "ECDH-X25519-CHALLENGE" + +clientFirst :: Maybe Text -> Text -> Text -> Maybe (AuthenticatePayload, Phase1) +clientFirst mbAuthz authc privateKeyText = + case Curve.importPrivate <$> B64.decode (Text.encodeUtf8 privateKeyText) of + Right (Just private) -> Just (AuthenticatePayload payload, Phase1 private) + _ -> Nothing + where + payload = + case mbAuthz of + Nothing -> Text.encodeUtf8 authc + Just authz -> Text.encodeUtf8 authc <> "\0" <> Text.encodeUtf8 authz + +clientResponse :: + Phase1 -> + ByteString {- ^ server response -} -> + Maybe AuthenticatePayload {- ^ client response -} +clientResponse (Phase1 privateKey) serverMessage = + do let (serverPubBS, (sessionSalt, maskedChallenge)) = + B.splitAt 32 <$> B.splitAt 32 serverMessage + guard (B.length maskedChallenge == 32) + serverPublic <- Curve.importPublic serverPubBS + + let sharedSecret = Curve.makeShared privateKey serverPublic + let clientPublic = Curve.generatePublic privateKey + let ikm = digestBS sha256 + $ sharedSecret <> Curve.exportPublic clientPublic <> serverPubBS + let prk = hmacBS sha256 sessionSalt ikm + let betterSecret = hmacBS sha256 prk "ECDH-X25519-CHALLENGE\1" + let sessionChallenge = B.pack (B.zipWith xor maskedChallenge betterSecret) + Just $! AuthenticatePayload sessionChallenge + +sha256 :: Digest +Just sha256 = unsafePerformIO (getDigestByName "SHA256") 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 @@ -7,8 +7,7 @@ Maintainer : emertens@gmail.com Implementation of ECDSA-NIST256P-CHALLENGE SASL authentication mode -as implemented at and used -on Freenode. +as implemented at . Using this mode requires that the @ecdsa@ utility program is available in your search path. @@ -38,11 +37,13 @@ -- | Encode a username as specified in this authentication mode. encodeAuthentication :: - Text {- ^ authorization identity -} -> + Maybe Text {- ^ authorization identity -} -> Text {- ^ authentication identity -} -> AuthenticatePayload -encodeAuthentication authz authc = - AuthenticatePayload (Text.encodeUtf8 (authz <> "\0" <> authc <> "\0")) +encodeAuthentication Nothing authc = + AuthenticatePayload (Text.encodeUtf8 authc) +encodeAuthentication (Just authz) authc = + AuthenticatePayload (Text.encodeUtf8 (authc <> "\0" <> authz)) -- | Compute the response for a given challenge using the @ecdsatool@ diff --git a/src/Client/Authentication/Scram.hs b/src/Client/Authentication/Scram.hs new file mode 100644 --- /dev/null +++ b/src/Client/Authentication/Scram.hs @@ -0,0 +1,184 @@ +{-# Language BlockArguments #-} +{-# Language ImportQualifiedPost #-} +{-# Language LambdaCase #-} +{-# Language OverloadedStrings #-} +{-# Language RecordWildCards #-} +{-# Language ViewPatterns #-} +module Client.Authentication.Scram ( + -- * Transaction state types + Phase1, + Phase2, + -- * Transaction step functions + initiateScram, + addServerFirst, + addServerFinal, + -- * Digests + ScramDigest(..), + mechanismName, + ) where + +import Control.Monad (guard) +import Data.Bits (xor) +import Data.ByteString (ByteString) +import Data.ByteString qualified as B +import Data.ByteString.Base64 qualified as B64 +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 System.IO.Unsafe (unsafePerformIO) + +data ScramDigest + = ScramDigestSha1 + | ScramDigestSha2_256 + | ScramDigestSha2_512 + deriving Show + +mechanismName :: ScramDigest -> Text +mechanismName digest = + case digest of + ScramDigestSha1 -> "SCRAM-SHA-1" + ScramDigestSha2_256 -> "SCRAM-SHA-256" + ScramDigestSha2_512 -> "SCRAM-SHA-512" + +-- | SCRAM state waiting for server-first-message +data Phase1 = Phase1 + { phase1Digest :: ScramDigest -- ^ underlying cryptographic hash function + , phase1Password :: ByteString -- ^ password + , phase1CbindInput :: ByteString -- ^ cbind-input + , phase1Nonce :: ByteString -- ^ c-nonce + , phase1ClientFirstBare :: ByteString -- ^ client-first-bare + } + +-- | Construct client-first-message and extra parameters +-- needed for 'addServerFirst'. +initiateScram :: + ScramDigest -> + ByteString {- ^ authentication ID -} -> + ByteString {- ^ authorization ID -} -> + ByteString {- ^ password -} -> + ByteString {- ^ nonce -} -> + (AuthenticatePayload, Phase1) +initiateScram digest user authzid pass nonce = + (AuthenticatePayload clientFirstMessage, Phase1 + { phase1Digest = digest + , phase1Password = pass + , phase1CbindInput = B64.encode gs2Header + , phase1Nonce = nonce + , phase1ClientFirstBare = clientFirstMessageBare + }) + where + clientFirstMessage = gs2Header <> clientFirstMessageBare + gs2Header = "n," <> encodeUsername authzid <> "," + clientFirstMessageBare = "n=" <> encodeUsername user <> ",r=" <> nonce + +-- | SCRAM state waiting for server-final-message +newtype Phase2 = Phase2 + { phase2ServerSignature :: ByteString -- ^ base64 encoded expected value + } + +-- | Add server-first-message to current SCRAM transaction, +-- compute client-final-message and next state for 'addServerFinal'. +addServerFirst :: + Phase1 {- ^ output of 'initiateScram' -} -> + ByteString {- ^ server first message -} -> + Maybe (AuthenticatePayload, Phase2) +addServerFirst Phase1{..} serverFirstMessage = + + do -- Parse server-first-message + ("r", nonce) : + ("s", B64.decode -> Right salt) : + ("i", B8.readInt -> Just (iterations, "")) : + _extensions + <- Just (parseMessage serverFirstMessage) + + -- validate nonce given by server includes ours and isn't empty + guard (B.isPrefixOf phase1Nonce nonce && phase1Nonce /= nonce) + + let clientFinalWithoutProof = "c=" <> phase1CbindInput <> ",r=" <> nonce + + let authMessage = + phase1ClientFirstBare <> "," <> + serverFirstMessage <> "," <> + clientFinalWithoutProof + + let (clientProof, serverSignature) = + crypto phase1Digest phase1Password salt iterations authMessage + + let proof = "p=" <> B64.encode clientProof + let clientFinalMessage = clientFinalWithoutProof <> "," <> proof + + let phase2 = Phase2 { phase2ServerSignature = B64.encode serverSignature } + Just (AuthenticatePayload clientFinalMessage, phase2) + +-- | Add server-final-message to transaction and compute validatity of +-- the whole transaction. +addServerFinal :: + Phase2 {- ^ output of 'addServerFirst' -} -> + ByteString {- ^ server-final-message -} -> + Bool {- ^ transaction succeeded? -} +addServerFinal Phase2{..} serverFinalMessage = + case parseMessage serverFinalMessage of + ("v", sig) : _extensions -> sig == phase2ServerSignature + _ -> False + +-- | Big endian encoding of a 32-bit number 1. +int1 :: ByteString +int1 = B.pack [0,0,0,1] + +xorBS :: ByteString -> ByteString -> ByteString +xorBS x y = B.pack (B.zipWith xor x y) + +-- | Iterated, password-based, key-derivation function. +hi :: + Digest {- ^ underlying cryptographic hash function -} -> + ByteString {- ^ secret -} -> + ByteString {- ^ salt -} -> + Int {- ^ iterations -} -> + ByteString {- ^ salted, iterated hash of secret -} +hi digest str salt n = foldl1' xorBS (take n us) + where + u1 = hmacBS digest str (salt <> int1) + us = iterate (hmacBS digest str) u1 + +-- | Break up a SCRAM message into its underlying key-value association list. +parseMessage :: ByteString -> [(ByteString, ByteString)] +parseMessage msg = + [case B8.break ('='==) entry of + (key, value) -> (key, B.drop 1 value) + | entry <- B8.split ',' msg] + +-- | Tranform all the SCRAM parameters into a @ClientProof@ +-- and @ServerSignature@. +crypto :: + ScramDigest {- ^ digest -} -> + ByteString {- ^ password -} -> + ByteString {- ^ salt -} -> + Int {- ^ iterations -} -> + ByteString {- ^ auth message -} -> + (ByteString, ByteString) {- ^ client-proof, server-signature -} +crypto digest password salt iterations authMessage = + (clientProof, serverSignature) + where + saltedPassword = hi d password salt iterations + clientKey = hmacBS d saltedPassword "Client Key" + storedKey = digestBS d clientKey + clientSignature = hmacBS d storedKey authMessage + clientProof = xorBS clientKey clientSignature + serverKey = hmacBS d saltedPassword "Server Key" + serverSignature = hmacBS d serverKey authMessage + digestName = + case digest of + ScramDigestSha1 -> "SHA1" + ScramDigestSha2_256 -> "SHA256" + ScramDigestSha2_512 -> "SHA512" + Just d = unsafePerformIO (getDigestByName digestName) + +-- | Encode usersnames so they fit in the comma/equals delimited +-- SCRAM message format. +encodeUsername :: ByteString -> ByteString +encodeUsername = B8.concatMap \case + ',' -> "=2C" + '=' -> "=3D" + x -> B8.singleton x 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 @@ -1,4 +1,4 @@ -{-# Language RecordWildCards #-} +{-# Language OverloadedStrings, RecordWildCards #-} {-| Module : Client.CApi.Exports Description : Foreign exports which expose functionality for extensions @@ -248,7 +248,7 @@ now <- getZonedTime let msg = ClientMessage - { _msgBody = IrcBody (Privmsg (parseUserInfo src) tgt txt) + { _msgBody = IrcBody (Privmsg (Source (parseUserInfo src) "") tgt txt) , _msgTime = now , _msgNetwork = net } diff --git a/src/Client/Commands.hs b/src/Client/Commands.hs --- a/src/Client/Commands.hs +++ b/src/Client/Commands.hs @@ -94,7 +94,7 @@ rest = dropWhile (==' ') (dropWhile (/=' ') command) case views (clientConfig . configMacros) (recognize key) st of - Exact (Macro (MacroSpec spec) cmdExs) -> + Exact (Macro _ (MacroSpec spec) cmdExs) -> case doExpansion spec cmdExs rest of Nothing -> commandFailureMsg "macro expansions failed" st Just cmds -> process cmds st @@ -490,7 +490,7 @@ do sendMsg cs (ircPrivmsg channel msg) chatCommand' (\src tgt -> Privmsg src tgt msg) - channel + [channel] cs st1) st (filter (not . Text.null) msgs) currentNetworkState = 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 @@ -68,7 +68,7 @@ | placeholders = return (" " <> string (view palCommandPlaceholder pal) name) | otherwise = return mempty - draw = parseIrcText' True . Text.pack + draw = parseIrcText' True pal . Text.pack in case spec of 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 @@ -63,7 +63,7 @@ \\^BExample configuration:\^B\n\ \ servers:\n\ \ * name: \"fn\"\n\ - \ hostname: \"chat.freenode.net\"\n\ + \ hostname: \"irc.libera.chat\"\n\ \ sasl: mechanism: external\n\ \ tls: yes\n\ \ tls-client-cert: \"my.pem\"\n\ 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 @@ -31,7 +31,6 @@ import Irc.Identifier import Irc.Message import Irc.RawIrcMsg -import Irc.UserInfo chatCommands :: CommandSection chatCommands = CommandSection "IRC commands" @@ -200,7 +199,7 @@ , Command (pure "wallops") - (remainingArg "message") + (remainingArg "message to +w users") "\^BParameters:\^B\n\ \\n\ \ message: Formatted message body\n\ @@ -218,6 +217,25 @@ $ NetworkCommand cmdWallops simpleNetworkTab , Command + (pure "operwall") + (remainingArg "message to +z opers") + "\^BParameters:\^B\n\ + \\n\ + \ message: Formatted message body\n\ + \\n\ + \\^BDescription:\^B\n\ + \\n\ + \ Send a network-wide WALLOPS message to opers. These message go\n\ + \ out to opers who have the 'z' usermode set.\n\ + \\n\ + \\^BExamples:\^B\n\ + \\n\ + \ /operwall What's this even for?\n\ + \\n\ + \\^BSee also:\^B me, msg, say\n" + $ NetworkCommand cmdOperwall simpleNetworkTab + + , Command (pure "ctcp") (liftA3 (,,) (simpleToken "target") (simpleToken "command") (remainingArg "arguments")) "\^BParameters:\^B\n\ @@ -279,7 +297,7 @@ $ NetworkCommand cmdAway simpleNetworkTab , Command - ("users" :| ["names"]) + (pure "names") (pure ()) "\^BDescription:\^B\n\ \\n\ @@ -289,7 +307,7 @@ \ Press ESC to exit the userlist.\n\ \\n\ \\^BSee also:\^B channelinfo, masks\n" - $ ChannelCommand cmdUsers noChannelTab + $ ChannelCommand cmdChanNames noChannelTab , Command (pure "channelinfo") @@ -352,8 +370,8 @@ do sendMsg cs (ircMonitor (fmap Text.pack args)) commandSuccess st -cmdUsers :: ChannelCommand () -cmdUsers _ _ st _ = commandSuccess (changeSubfocus FocusUsers st) +cmdChanNames :: ChannelCommand () +cmdChanNames _ _ st _ = commandSuccess (changeSubfocus FocusUsers st) cmdChannelInfo :: ChannelCommand () cmdChannelInfo _ _ st _ = commandSuccess (changeSubfocus FocusInfo st) @@ -383,10 +401,10 @@ | Just cs <- preview (clientConnection net) st -> do let tgtTxt = idText tgt msgTxt = Text.pack msg - sendMsg cs (ircPrivmsg tgtTxt msgTxt) chatCommand - (\src tgt1 -> Privmsg src tgt1 msgTxt) - tgtTxt cs st' + (ircPrivmsg tgtTxt msgTxt) + (\src tgt1 -> Privmsg src tgt1 msgTxt) + tgtTxt cs st' where firstTgt = mkId (Text.takeWhile (','/=) (idText tgt)) st' = changeFocus (ChannelFocus net firstTgt) st @@ -396,17 +414,17 @@ -- | Implementation of @/ctcp@ cmdCtcp :: NetworkCommand (String, String, String) cmdCtcp cs st (target, cmd, args) = - do let cmdTxt = Text.toUpper (Text.pack cmd) - argTxt = Text.pack args - tgtTxt = Text.pack target + do let cmdTxt = Text.toUpper (Text.pack cmd) + argTxt = Text.pack args + tgtTxt = Text.pack target - sendMsg cs (ircPrivmsg tgtTxt - ("\^A" <> cmdTxt <> - (if Text.null argTxt then "" else " " <> argTxt) <> - "\^A")) - chatCommand - (\src tgt -> Ctcp src tgt cmdTxt argTxt) - tgtTxt cs st + let msg = "\^A" <> cmdTxt <> + (if Text.null argTxt then "" else " " <> argTxt) <> + "\^A" + chatCommand + (ircPrivmsg tgtTxt msg) + (\src tgt -> Ctcp src tgt cmdTxt argTxt) + tgtTxt cs st -- | Implementation of @/wallops@ cmdWallops :: NetworkCommand String @@ -417,54 +435,69 @@ sendMsg cs (ircWallops restTxt) commandSuccess st +-- | Implementation of @/operwall@ +cmdOperwall :: NetworkCommand String +cmdOperwall cs st rest + | null rest = commandFailureMsg "empty message" st + | otherwise = + do let restTxt = Text.pack rest + sendMsg cs (ircOperwall restTxt) + commandSuccess st + -- | Implementation of @/notice@ cmdNotice :: NetworkCommand (String, String) cmdNotice cs st (target, rest) | null rest = commandFailureMsg "empty message" st | otherwise = - do let restTxt = Text.pack rest - tgtTxt = Text.pack target - - sendMsg cs (ircNotice tgtTxt restTxt) - chatCommand - (\src tgt -> Notice src tgt restTxt) - tgtTxt cs st + do let restTxt = Text.pack rest + tgtTxt = Text.pack target + chatCommand + (ircNotice tgtTxt restTxt) + (\src tgt -> Notice src tgt restTxt) + tgtTxt cs st -- | Implementation of @/msg@ cmdMsg :: NetworkCommand (String, String) cmdMsg cs st (target, rest) | null rest = commandFailureMsg "empty message" st | otherwise = - do let restTxt = Text.pack rest - tgtTxt = Text.pack target + do let restTxt = Text.pack rest + tgtTxt = Text.pack target + chatCommand + (ircPrivmsg tgtTxt restTxt) + (\src tgt -> Privmsg src tgt restTxt) + tgtTxt cs st + - sendMsg cs (ircPrivmsg tgtTxt restTxt) - chatCommand - (\src tgt -> Privmsg src tgt restTxt) - tgtTxt cs st -- | Common logic for @/msg@ and @/notice@ chatCommand :: - (UserInfo -> Identifier -> IrcMsg) -> - Text {- ^ target -} -> + RawIrcMsg {- ^ irc command -} -> + (Source -> Identifier -> IrcMsg) -> + Text {- ^ targets -} -> NetworkState -> ClientState -> IO CommandResult -chatCommand mkmsg target cs st = - commandSuccess =<< chatCommand' mkmsg target cs st +chatCommand ircMsg mkmsg tgtsTxt cs st + | any Text.null tgtTxts = commandFailureMsg "empty target" st + | otherwise = + do sendMsg cs ircMsg + st' <- chatCommand' mkmsg tgtTxts cs st + commandSuccess st' + where + tgtTxts = Text.split (','==) tgtsTxt -- | Common logic for @/msg@ and @/notice@ returning the client state chatCommand' :: - (UserInfo -> Identifier -> IrcMsg) -> - Text {- ^ target -} -> + (Source -> Identifier -> IrcMsg) -> + [Text] {- ^ targets -} -> NetworkState -> ClientState -> IO ClientState -chatCommand' con targetsTxt cs st = +chatCommand' con targetTxts cs st = do now <- getZonedTime - let targetTxts = Text.split (==',') targetsTxt - targetIds = mkId <$> targetTxts - !myNick = UserInfo (view csNick cs) "" "" + let targetIds = mkId <$> targetTxts + !myNick = Source (view csUserInfo cs) "" network = view csNetwork cs entries = [ (targetId, ClientMessage @@ -515,7 +548,7 @@ cmdMe channelId cs st rest = do now <- getZonedTime let actionTxt = Text.pack ("\^AACTION " ++ rest ++ "\^A") - !myNick = UserInfo (view csNick cs) "" "" + !myNick = Source (view csUserInfo cs) "" network = view csNetwork cs entry = ClientMessage { _msgTime = now @@ -543,7 +576,7 @@ when allow (sendMsg cs (ircPrivmsg tgtTxt msgTxt)) - let myNick = UserInfo (view csNick cs) "" "" + let myNick = Source (view csUserInfo cs) "" entry = ClientMessage { _msgTime = now , _msgNetwork = network 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 @@ -51,7 +51,8 @@ data Macro = Macro - { macroSpec :: MacroSpec + { macroName :: Text + , macroSpec :: MacroSpec , macroCommands :: [[ExpansionChunk]] } deriving Show 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 @@ -14,9 +14,10 @@ import Client.Commands.TabCompletion import Client.Commands.Types import Client.State.Network (sendMsg) -import Data.Maybe (fromMaybe) +import Data.Maybe (fromMaybe, maybeToList) import qualified Data.Text as Text import Irc.Commands +import Irc.RawIrcMsg operatorCommands :: CommandSection operatorCommands = CommandSection "Network operator commands" @@ -41,17 +42,47 @@ , Command (pure "unkline") - (simpleToken "user@host") + (liftA2 (,) (simpleToken "[user@]host") (optionalArg (simpleToken "[servername]"))) "Unban a client from the server.\n" $ NetworkCommand cmdUnkline simpleNetworkTab , Command + (pure "undline") + (liftA2 (,) (simpleToken "host") (optionalArg (simpleToken "[servername]"))) + "Unban a client from the server.\n" + $ NetworkCommand cmdUndline simpleNetworkTab + + , Command + (pure "unxline") + (liftA2 (,) (simpleToken "gecos") (optionalArg (simpleToken "[servername]"))) + "Unban a gecos from the server.\n" + $ NetworkCommand cmdUnxline simpleNetworkTab + + , Command + (pure "unresv") + (liftA2 (,) (simpleToken "channel|nick") (optionalArg (simpleToken "[servername]"))) + "Unban a channel or nickname from the server.\n" + $ NetworkCommand cmdUnresv simpleNetworkTab + + , Command (pure "testline") (simpleToken "[[nick!]user@]host") "Check matching I/K/D lines for a [[nick!]user@]host\n" $ NetworkCommand cmdTestline simpleNetworkTab , Command + (pure "testkline") + (simpleToken "[user@]host") + "Check matching K/D lines for a [user@]host\n" + $ NetworkCommand cmdTestkline simpleNetworkTab + + , Command + (pure "testgecos") + (simpleToken "gecos") + "Check matching X lines for a gecos\n" + $ NetworkCommand cmdTestGecos simpleNetworkTab + + , Command (pure "testmask") (liftA2 (,) (simpleToken "[nick!]user@host") (remainingArg "[gecos]")) "Test how many local and global clients match a mask.\n" @@ -87,8 +118,112 @@ "Display network map.\n" $ NetworkCommand cmdMap simpleNetworkTab + , Command + (pure "sconnect") + (liftA2 (,) (simpleToken "connect_to") (optionalArg (liftA2 (,) (simpleToken "[port]") (optionalArg (simpleToken "[remote]"))))) + "Connect two servers together.\n" + $ NetworkCommand cmdSconnect simpleNetworkTab + + , Command + (pure "squit") + (liftA2 (,) (simpleToken "server") (remainingArg "[reason]")) + "Split a server away from your side of the network.\n" + $ NetworkCommand cmdSquit simpleNetworkTab + + , Command + (pure "modload") + (liftA2 (,) (simpleToken "[path/]module") (optionalArg (simpleToken "[remote]"))) + "Load an IRCd module.\n" + $ NetworkCommand cmdModload simpleNetworkTab + + , Command + (pure "modunload") + (liftA2 (,) (simpleToken "module") (optionalArg (simpleToken "[remote]"))) + "Unload an IRCd module.\n" + $ NetworkCommand cmdModunload simpleNetworkTab + + , Command + (pure "modlist") + (optionalArg (liftA2 (,) (simpleToken "pattern") (optionalArg (simpleToken "[remote]")))) + "List loaded IRCd modules.\n" + $ NetworkCommand cmdModlist simpleNetworkTab + + , Command + (pure "modrestart") + (optionalArg (simpleToken "[server]")) + "Reload all IRCd modules.\n" + $ NetworkCommand cmdModrestart simpleNetworkTab + + , Command + (pure "modreload") + (liftA2 (,) (simpleToken "module") (optionalArg (simpleToken "[remote]"))) + "Reload an IRCd module.\n" + $ NetworkCommand cmdModreload simpleNetworkTab + + , Command + (pure "grant") + (liftA2 (,) (simpleToken "target") (simpleToken "privset")) + "Manually assign a privset to a user.\n" + $ NetworkCommand cmdGrant simpleNetworkTab + + , Command + (pure "privs") + (optionalArg (simpleToken "[target]")) + "Check operator privileges of the target.\n" + $ NetworkCommand cmdPrivs simpleNetworkTab ] +cmdGrant :: NetworkCommand (String, String) +cmdGrant cs st (target, privset) = + do sendMsg cs (rawIrcMsg "GRANT" (Text.pack <$> [target, privset])) + commandSuccess st + +cmdPrivs :: NetworkCommand (Maybe String) +cmdPrivs cs st mbTarget = + do sendMsg cs (rawIrcMsg "PRIVS" (Text.pack <$> maybeToList mbTarget)) + commandSuccess st + +cmdModlist :: NetworkCommand (Maybe (String, Maybe String)) +cmdModlist cs st args = + do let argList = case args of + Nothing -> [] + Just (x, xs) -> x : maybeToList xs + sendMsg cs (rawIrcMsg "MODLIST" (Text.pack <$> argList)) + commandSuccess st + +cmdModrestart :: NetworkCommand (Maybe String) +cmdModrestart cs st args = + do sendMsg cs (rawIrcMsg "MODRESTART" (Text.pack <$> maybeToList args)) + commandSuccess st + +cmdModload :: NetworkCommand (String, Maybe String) +cmdModload cs st (mod_, remote) = + do sendMsg cs (rawIrcMsg "MODLOAD" (Text.pack <$> (mod_ : maybeToList remote))) + commandSuccess st + +cmdModunload :: NetworkCommand (String, Maybe String) +cmdModunload cs st (mod_, remote) = + do sendMsg cs (rawIrcMsg "MODUNLOAD" (Text.pack <$> (mod_ : maybeToList remote))) + commandSuccess st + +cmdModreload :: NetworkCommand (String, Maybe String) +cmdModreload cs st (mod_, remote) = + do sendMsg cs (rawIrcMsg "MODRELOAD" (Text.pack <$> (mod_ : maybeToList remote))) + commandSuccess st + +cmdSquit :: NetworkCommand (String, String) +cmdSquit cs st (server, reason) = + do sendMsg cs (rawIrcMsg "SQUIT" (Text.pack <$> [server, reason])) + commandSuccess st + +cmdSconnect :: NetworkCommand (String, Maybe (String, Maybe String)) +cmdSconnect cs st (server, rest) = + do let args = case rest of + Nothing -> [server] + Just (x, xs) -> server : x : maybeToList xs + sendMsg cs (rawIrcMsg "CONNECT" (Text.pack <$> args)) + commandSuccess st + cmdKill :: NetworkCommand (String, String) cmdKill cs st (client,rest) = do sendMsg cs (ircKill (Text.pack client) (Text.pack rest)) @@ -99,14 +234,39 @@ do sendMsg cs (ircKline (Text.pack minutes) (Text.pack mask) (Text.pack reason)) commandSuccess st -cmdUnkline :: NetworkCommand String -cmdUnkline cs st mask = - do sendMsg cs (ircUnkline (Text.pack mask)) +cmdUnkline :: NetworkCommand (String, Maybe String) +cmdUnkline cs st (mask, server) = + do sendMsg cs (ircUnkline (Text.pack mask) (Text.pack <$> server)) commandSuccess st +cmdUndline :: NetworkCommand (String, Maybe String) +cmdUndline cs st (mask, server) = + do sendMsg cs (ircUndline (Text.pack mask) (Text.pack <$> server)) + commandSuccess st + +cmdUnxline :: NetworkCommand (String, Maybe String) +cmdUnxline cs st (mask, server) = + do sendMsg cs (ircUnxline (Text.pack mask) (Text.pack <$> server)) + commandSuccess st + +cmdUnresv :: NetworkCommand (String, Maybe String) +cmdUnresv cs st (mask, server) = + do sendMsg cs (ircUnresv (Text.pack mask) (Text.pack <$> server)) + commandSuccess st + cmdTestline :: NetworkCommand String cmdTestline cs st mask = do sendMsg cs (ircTestline (Text.pack mask)) + commandSuccess st + +cmdTestkline :: NetworkCommand String +cmdTestkline cs st mask = + do sendMsg cs (rawIrcMsg "TESTKLINE" [Text.pack mask]) + commandSuccess st + +cmdTestGecos :: NetworkCommand String +cmdTestGecos cs st mask = + do sendMsg cs (rawIrcMsg "TESTGECOS" [Text.pack mask]) commandSuccess st cmdTestmask :: NetworkCommand (String, String) 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 @@ -9,7 +9,6 @@ module Client.Commands.Queries (queryCommands) where -import Control.Applicative import Client.Commands.Arguments.Spec import Client.Commands.TabCompletion import Client.Commands.Types @@ -64,11 +63,17 @@ , Command (pure "lusers") - (optionalArg (liftA2 (,) (simpleToken "mask") (optionalArg (simpleToken "[servername]")))) - "Send LUSERS query to server with given arguments.\n" + (optionalArg (simpleToken "[servername]")) + "Send LUSERS query to a given server.\n" $ NetworkCommand cmdLusers simpleNetworkTab , Command + (pure "users") + (optionalArg (simpleToken "[servername]")) + "Send USERS query to a given server.\n" + $ NetworkCommand cmdUsers simpleNetworkTab + + , Command (pure "motd") (optionalArg (simpleToken "[servername]")) "Send MOTD query to server.\n" $ NetworkCommand cmdMotd simpleNetworkTab @@ -123,13 +128,17 @@ do sendMsg cs (ircList (Text.pack <$> words rest)) commandSuccess st -cmdLusers :: NetworkCommand (Maybe (String, Maybe String)) +cmdLusers :: NetworkCommand (Maybe String) cmdLusers cs st arg = do sendMsg cs $ ircLusers $ fmap Text.pack $ case arg of - Nothing -> [] - Just (x, Nothing) -> [x] - Just (x, Just y) -> [x,y] + Nothing -> [] + Just x -> ["*", x] -- mask field is legacy + commandSuccess st + +cmdUsers :: NetworkCommand (Maybe String) +cmdUsers cs st arg = + do sendMsg cs $ ircUsers $ maybe "" Text.pack arg commandSuccess st cmdMotd :: NetworkCommand (Maybe String) 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 @@ -1,4 +1,4 @@ -{-# Language OverloadedStrings, DeriveFunctor #-} +{-# Language OverloadedStrings, DeriveTraversable #-} {-| Module : Client.Commands.Recognizer @@ -35,7 +35,7 @@ -- detailed information when looking up keys that are not actually in the map. data Recognizer a = Branch !Text !(Maybe a) !(HashMap Char (Recognizer a)) - deriving (Show, Functor) + deriving (Show, Functor, Foldable) instance Monoid (Recognizer a) where mempty = Branch "" Nothing empty 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 @@ -98,7 +98,7 @@ toListOf ( clientWindows . ix focus . winMessages . each - . wlSummary . folding summaryActor + . wlSummary . folding chatActor . filtered isActive . filtered isNotSelf ) st where @@ -117,7 +117,7 @@ -- Returns the 'Identifier' of the nickname responsible for -- the window line when that action was significant enough to -- be considered a hint for tab completion. - summaryActor :: IrcSummary -> Maybe Identifier - summaryActor (ChatSummary who) = Just $! userNick who - summaryActor _ = Nothing + chatActor :: IrcSummary -> Maybe Identifier + chatActor (ChatSummary who) = Just $! userNick who + chatActor _ = Nothing 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 @@ -51,8 +51,14 @@ , Command (pure "toggle-editor") (pure ()) - "Toggle editor mode.\n" + "Toggle between single-line and multi-line editor mode.\n" $ ClientCommand cmdToggleEditor noClientTab + + , Command + (pure "toggle-edit-lock") + (pure ()) + "Toggle editor lock mode. When editor is locked pressing Enter is disabled.\n" + $ ClientCommand cmdToggleEditLock noClientTab ] cmdToggleDetail :: ClientCommand () @@ -78,3 +84,6 @@ where aux SingleLineEditor = MultiLineEditor aux MultiLineEditor = SingleLineEditor + +cmdToggleEditLock :: ClientCommand () +cmdToggleEditLock st _ = commandSuccess (over clientEditLock not st) diff --git a/src/Client/Configuration.hs b/src/Client/Configuration.hs --- a/src/Client/Configuration.hs +++ b/src/Client/Configuration.hs @@ -4,6 +4,7 @@ {-# LANGUAGE TemplateHaskell #-} {-# LANGUAGE ApplicativeDo #-} {-# LANGUAGE RankNTypes #-} +{-# LANGUAGE LambdaCase #-} {-| Module : Client.Configuration @@ -44,6 +45,7 @@ , configLayout , configShowPing , configJumpModifier + , configDigraphs , extensionPath , extensionRtldFlags @@ -84,11 +86,14 @@ 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) @@ -119,6 +124,7 @@ , _configLayout :: LayoutMode -- ^ Default layout on startup , _configShowPing :: Bool -- ^ visibility of ping time , _configJumpModifier :: [Modifier] -- ^ Modifier used for jumping windows + , _configDigraphs :: Map Digraph Text -- ^ Extra digraphs } deriving Show @@ -286,6 +292,8 @@ "Initial setting for window layout" _configShowPing <- sec' True "show-ping" yesOrNoSpec "Initial setting for visibility of ping times" + _configDigraphs <- sec' mempty "extra-digraphs" (Map.fromList <$> listSpec digraphSpec) + "Extra digraphs" return (\def -> let _configDefaults = snd ssDefUpdate def _configServers = buildServerMap _configDefaults ssUpdates @@ -473,6 +481,17 @@ argSpec = UrlArgUrl <$ atomSpec "url" UrlArgLiteral <$> stringSpec + +digraphSpec :: ValueSpec (Digraph, Text) +digraphSpec = + sectionsSpec "digraph" $ + do ~(x,y) <- reqSection' "input" twoChars "digraph key" + val <- reqSection' "output" textSpec "replacement text" + pure (Digraph x y, val) + where + twoChars = customSpec "two" stringSpec $ \case + [x,y] -> Right (x,y) + _ -> Left "exactly two characters required" buildServerMap :: ServerSettings {- ^ defaults -} -> 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 @@ -29,7 +29,7 @@ spec <- fromMaybe noMacroArguments <$> optSection' "arguments" macroArgumentsSpec "" commands <- reqSection' "commands" (oneOrList macroCommandSpec) "" - return (name, Macro spec commands) + return (name, Macro name spec commands) macroArgumentsSpec :: ValueSpec MacroSpec macroArgumentsSpec = customSpec "macro-arguments" anySpec parseMacroSpecs 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 #-} +{-# LANGUAGE ApplicativeDo, TemplateHaskell, OverloadedStrings, RecordWildCards, BlockArguments #-} {-| Module : Client.Configuration.ServerSettings @@ -35,6 +35,7 @@ , ssTlsClientKeyPassword , ssTlsServerCert , ssTlsCiphers + , ssTls13Ciphers , ssConnectCmds , ssSocksHost , ssSocksPort @@ -60,6 +61,7 @@ , _SaslExternal , _SaslEcdsa , _SaslPlain + , _SaslScram -- * Secrets , Secret(..) @@ -79,6 +81,7 @@ , getRegex ) where +import Client.Authentication.Scram (ScramDigest(..)) import Client.Commands.Interpolation import Client.Commands.WordCompletion import Client.Configuration.Macros (macroCommandSpec) @@ -102,6 +105,7 @@ import qualified System.Process as Process import Text.Regex.TDFA import Text.Regex.TDFA.Text (compile) +import Hookup (TlsVerify(..)) -- | Static server-level settings data ServerSettings = ServerSettings @@ -113,12 +117,13 @@ , _ssHostName :: !HostName -- ^ server hostname , _ssPort :: !(Maybe PortNumber) -- ^ server port , _ssTls :: !TlsMode -- ^ use TLS to connect - , _ssTlsVerify :: !Bool -- ^ verify TLS hostname + , _ssTlsVerify :: !TlsVerify -- ^ verify TLS hostname , _ssTlsClientCert :: !(Maybe FilePath) -- ^ path to client TLS certificate , _ssTlsClientKey :: !(Maybe FilePath) -- ^ path to client TLS key , _ssTlsClientKeyPassword :: !(Maybe Secret) -- ^ client key PEM password , _ssTlsServerCert :: !(Maybe FilePath) -- ^ additional CA certificates for validating server , _ssTlsCiphers :: String -- ^ OpenSSL cipher suite + , _ssTls13Ciphers :: Maybe String -- ^ OpenSSL TLS 1.3 cipher suite , _ssTlsPubkeyFingerprint :: !(Maybe Fingerprint) -- ^ optional acceptable public key fingerprint , _ssTlsCertFingerprint :: !(Maybe Fingerprint) -- ^ optional acceptable certificate fingerprint , _ssSts :: !Bool -- ^ Honor STS policies when true @@ -154,6 +159,8 @@ = SaslPlain (Maybe Text) Text Secret -- ^ SASL PLAIN RFC4616 - authzid authcid password | SaslEcdsa (Maybe Text) Text FilePath -- ^ SASL NIST - https://github.com/kaniini/ecdsatool - authzid keypath | SaslExternal (Maybe Text) -- ^ SASL EXTERNAL RFC4422 - authzid + | SaslScram ScramDigest (Maybe Text) Text Secret -- ^ SASL SCRAM-SHA-256 RFC7677 - authzid authcid password + | SaslEcdh (Maybe Text) Text Secret -- ^ SASL ECDH-X25519-CHALLENGE - authzid authcid private-key deriving Show -- | Regular expression matched with original source to help with debugging. @@ -197,12 +204,13 @@ , _ssHostName = "" , _ssPort = Nothing , _ssTls = TlsNo - , _ssTlsVerify = True + , _ssTlsVerify = VerifyDefault , _ssTlsClientCert = Nothing , _ssTlsClientKey = Nothing , _ssTlsClientKeyPassword = Nothing , _ssTlsServerCert = Nothing , _ssTlsCiphers = "HIGH" + , _ssTls13Ciphers = Nothing , _ssTlsPubkeyFingerprint = Nothing , _ssTlsCertFingerprint = Nothing , _ssSts = True @@ -272,24 +280,27 @@ , req "tls" ssTls tlsModeSpec "Use TLS to connect (default no)" - , req "tls-verify" ssTlsVerify yesOrNoSpec - "Enable server certificate hostname verification (default yes)" + , req "tls-verify" ssTlsVerify tlsVerifySpec + "Enable server certificate hostname verification (default yes, string to override hostname)" - , opt "tls-client-cert" ssTlsClientCert stringSpec + , opt "tls-client-cert" ssTlsClientCert filepathSpec "Path to TLS client certificate" - , opt "tls-client-key" ssTlsClientKey stringSpec + , opt "tls-client-key" ssTlsClientKey filepathSpec "Path to TLS client key" , opt "tls-client-key-password" ssTlsClientKeyPassword anySpec "Password for decrypting TLS client key PEM file" - , opt "tls-server-cert" ssTlsServerCert stringSpec + , opt "tls-server-cert" ssTlsServerCert filepathSpec "Path to CA certificate bundle" , req "tls-ciphers" ssTlsCiphers stringSpec "OpenSSL cipher specification. Default to \"HIGH\"" + , opt "tls-1.3-ciphers" ssTls13Ciphers stringSpec + "OpenSSL TLS 1.3 cipher specification." + , opt "socks-host" ssSocksHost stringSpec "Hostname of SOCKS5 proxy server" @@ -323,7 +334,7 @@ , req "nick-completion" ssNickCompletion nickCompletionSpec "Behavior for nickname completion with TAB" - , opt "log-dir" ssLogDir stringSpec + , opt "log-dir" ssLogDir filepathSpec "Path to log file directory for this server" , opt "bind-hostname" ssBindHostName stringSpec @@ -351,8 +362,14 @@ TlsNo <$ atomSpec "no" TlsStart <$ atomSpec "starttls" +tlsVerifySpec :: ValueSpec TlsVerify +tlsVerifySpec = + VerifyDefault <$ atomSpec "yes" + VerifyNone <$ atomSpec "no" + VerifyHostname <$> stringSpec + saslMechanismSpec :: ValueSpec SaslMechanism -saslMechanismSpec = plain external ecdsa +saslMechanismSpec = plain external ecdsa scram ecdh where mech m = reqSection' "mechanism" (atomSpec m) "Mechanism" authzid = optSection "authzid" "Authorization identity" @@ -371,8 +388,37 @@ sectionsSpec "sasl-ecdsa-nist256p-challenge-mech" $ SaslEcdsa <$ mech "ecdsa-nist256p-challenge" <*> authzid <*> username <*> - reqSection' "private-key" stringSpec "Private key file" + reqSection' "private-key" filepathSpec "Private key file" + scramDigest = + fromMaybe ScramDigestSha2_256 <$> + optSection' "digest" scramDigests "Underlying digest function" + + scramDigests = + ScramDigestSha1 <$ atomSpec "sha1" + ScramDigestSha2_256 <$ atomSpec "sha2-256" + ScramDigestSha2_512 <$ atomSpec "sha2-512" + + scram = + sectionsSpec "sasl-scram" $ + SaslScram <$ mech "scram" <*> + scramDigest <*> + authzid <*> username <*> reqSection "password" "Password" + + ecdh = + sectionsSpec "sasl-ecdh-x25519-challenge" $ + SaslEcdh <$ mech "ecdh-x25519-challenge" <*> + authzid <*> username <*> reqSection "private-key" "Private Key" + + + + +filepathSpec :: ValueSpec FilePath +filepathSpec = customSpec "path" stringSpec $ \str -> + if null str + then Left "empty path" + else Right str + hookSpec :: ValueSpec HookConfig hookSpec = flip HookConfig [] <$> anySpec @@ -455,7 +501,9 @@ loadSecrets = traverseOf (ssPassword . _Just ) (loadSecret "server password") >=> traverseOf (ssSaslMechanism . _Just . _SaslPlain . _3) (loadSecret "SASL password") >=> - traverseOf (ssTlsClientKeyPassword . _Just ) (loadSecret "TLS key 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") -- | Run a command if found and replace it with the first line of stdout result. loadSecret :: String -> Secret -> IO Secret diff --git a/src/Client/EventLoop.hs b/src/Client/EventLoop.hs --- a/src/Client/EventLoop.hs +++ b/src/Client/EventLoop.hs @@ -19,7 +19,7 @@ import Client.CApi (ThreadEntry, popTimer) import Client.Commands -import Client.Configuration (configJumpModifier, configKeyMap, configWindowNames) +import Client.Configuration (configJumpModifier, configKeyMap, configWindowNames, configDigraphs) import Client.Configuration.ServerSettings import Client.EventLoop.Actions import Client.EventLoop.Errors (exceptionToLines) @@ -56,6 +56,7 @@ 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 @@ -65,7 +66,7 @@ -- | Sum of the five possible event types the event loop handles data ClientEvent - = VtyEvent Event -- ^ Key presses and resizing + = VtyEvent InternalEvent -- ^ Key presses and resizing | NetworkEvents (NonEmpty (Text, NetworkEvent)) -- ^ Incoming network events | TimerEvent Text TimedAction -- ^ Timed action and the applicable network | ExtTimerEvent Int -- ^ extension ID @@ -148,8 +149,10 @@ eventLoop vty =<< clientThreadJoin i result st' TimerEvent networkId action -> eventLoop vty =<< doTimerEvent networkId action st' - VtyEvent vtyEvent -> + VtyEvent (InputEvent vtyEvent) -> traverse_ (eventLoop vty) =<< doVtyEvent vty vtyEvent st' + VtyEvent ResumeAfterSignal -> + eventLoop vty =<< updateTerminalSize vty st NetworkEvents networkEvents -> eventLoop vty =<< foldM doNetworkEvent st' networkEvents @@ -454,7 +457,8 @@ ActUnderline -> changeEditor (Edit.insert '\^_') ActClearFormat -> changeEditor (Edit.insert '\^O') ActReverseVideo -> changeEditor (Edit.insert '\^V') - ActDigraph -> mbChangeEditor Edit.insertDigraph + ActMonospace -> changeEditor (Edit.insert '\^Q') + ActDigraph -> mbChangeEditor (Edit.insertDigraph (view (clientConfig . configDigraphs) st)) ActInsertEnter -> changeEditor (Edit.insert '\^J') -- focus jumps @@ -466,8 +470,8 @@ ActAdvanceNetwork -> continue (advanceNetworkFocus st) ActReset -> continue (changeSubfocus FocusMessages st) - ActOlderLine -> changeEditor $ \ed -> fromMaybe ed $ Edit.earlier ed - ActNewerLine -> changeEditor $ \ed -> fromMaybe ed $ Edit.later ed + ActOlderLine -> changeEditor $ \ed -> fromMaybe ed $ Edit.earlier ed + ActNewerLine -> changeEditor $ \ed -> fromMaybe ed $ Edit.later ed ActScrollUp -> continue (scrollClient ( scrollAmount st) st) ActScrollDown -> continue (scrollClient (-scrollAmount st) st) ActScrollUpSmall -> continue (scrollClient ( 3) st) @@ -477,7 +481,9 @@ ActTabComplete -> doCommandResult False =<< tabCompletion False st ActInsert c -> changeEditor (Edit.insert c) - ActEnter -> doCommandResult True =<< executeInput st + ActEnter -> if view clientEditLock st + then when (view clientBell st) (beep vty) >> continue st + else doCommandResult True =<< executeInput st ActRefresh -> refresh vty >> continue st ActCommand cmd -> do resp <- executeUserCommand Nothing (Text.unpack cmd) st case resp of 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 @@ -69,6 +69,7 @@ | ActUnderline | ActStrikethrough | ActReverseVideo + | ActMonospace | ActClearFormat | ActInsertEnter | ActDigraph @@ -140,6 +141,7 @@ ,("underline" , (ActUnderline , [ctrl (KChar '_')])) ,("clear-format" , (ActClearFormat , [ctrl (KChar 'o')])) ,("reverse-video" , (ActReverseVideo , [ctrl (KChar 'v')])) + ,("monospace" , (ActMonospace , [ctrl (KChar 'q')])) ,("insert-newline" , (ActInsertEnter , [meta KEnter])) ,("insert-digraph" , (ActDigraph , [meta (KChar 'k')])) @@ -236,6 +238,7 @@ , (KFun 4, ActCommand "toggle-metadata") , (KFun 5, ActCommand "toggle-layout") , (KFun 6, ActCommand "toggle-editor") + , (KFun 7, ActCommand "toggle-edit-lock") ]) : diff --git a/src/Client/Hook.hs b/src/Client/Hook.hs --- a/src/Client/Hook.hs +++ b/src/Client/Hook.hs @@ -34,6 +34,7 @@ = PassMessage -- ^ continue processing | OmitMessage -- ^ stop processing and drop message | RemapMessage IrcMsg -- ^ stop processing and return new message + deriving Show -- 'PassMessage' is an identity element instance Semigroup MessageResult where diff --git a/src/Client/Hook/DroneBLRelay.hs b/src/Client/Hook/DroneBLRelay.hs new file mode 100644 --- /dev/null +++ b/src/Client/Hook/DroneBLRelay.hs @@ -0,0 +1,216 @@ +{-# Language QuasiQuotes, OverloadedStrings #-} +{-| +Module : Client.Hook.DroneBLRelay +Description : Hook for interpreting DroneBL relay messages +Copyright : (c) Eric Mertens 2019 +License : ISC +Maintainer : emertens@gmail.com + +The #dronebl channels use a bot to relay messages from +other networks. This hook integrates those messages into the native +format. + +-} +module Client.Hook.DroneBLRelay + ( 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) + +-- | Hook for mapping messages in #dronebl +-- to appear like native messages. +droneblRelayHook :: [Text] -> Maybe MessageHook +droneblRelayHook args = Just (MessageHook "droneblrelay" False (remap (map mkId args))) + +-- | Remap messages from #dronebl that match one of the +-- rewrite rules. +remap :: [Identifier] -> IrcMsg -> MessageResult +remap nicks (Privmsg (Source (UserInfo nick _ _) _) chan@"#dronebl" msg) + | nick `elem` nicks + , Just sub <- rules chan msg = RemapMessage sub +remap _ _ = PassMessage + +-- | Generate a replacement message for a chat message +-- when the message matches one of the replacement rules. +rules :: + Identifier {- ^ channel -} -> + Text {- ^ message -} -> + Maybe IrcMsg +rules chan msg = + asum + [ rule (chatMsg chan) chatRe msg + , rule (actionMsg chan) actionRe msg + , rule (joinMsg chan) joinRe msg + , rule (partMsg chan) partRe msg + , rule quitMsg quitRe msg + , rule nickMsg nickRe msg + , rule (kickMsg chan) kickRe msg + , rule (modeMsg chan) modeRe msg + ] + +-- | Match the message against the regular expression and use the given +-- consume to consume all of the captured groups. +rule :: + Rule r => + r {- ^ capture consumer -} -> + Regex {- ^ regular expression -} -> + Text {- ^ message -} -> + Maybe IrcMsg +rule mk re s = + case map (map Text.pack) (match re (Text.unpack s)) of + [_:xs] -> matchRule xs mk + _ -> Nothing + +chatRe, actionRe, joinRe, quitRe, nickRe, partRe, kickRe, modeRe :: Regex +Right chatRe = compRe [str|^<([^>]+)> (.*)$|] +Right actionRe = compRe [str|^\* ([^ ]+) (.*)$|] +Right joinRe = compRe [str|^\*\*\* \[([^]]+)\] ([^ ]+) \(([^@]+)@([^)]+)\) has joined the channel$|] +Right quitRe = compRe [str|^\*\*\* \[([^]]+)\] ([^ ]+) has signed off \((.*)\)$|] +Right nickRe = compRe [str|^\*\*\* \[([^]]+)\] ([^ ]+) changed nick to ([^ ]+)$|] +Right partRe = compRe [str|^\*\*\* \[([^]]+)\] ([^ ]+) has left the channel( \((.*)\))?$|] +Right kickRe = compRe [str|^\*\*\* \[([^]]+)\] ([^ ]+) has been kicked by ([^ ]+) \((.*)\)$|] +Right modeRe = compRe [str|^\*\*\* \[([^]]+)\] ([^ ]+) sets mode (.*)$|] + +-- | Compile a regular expression for using in message matching. +compRe :: + Text {- ^ regular expression -} -> + Either String Regex {- ^ error or compiled expression -} +compRe = compile defaultCompOpt defaultExecOpt . Text.unpack + +------------------------------------------------------------------------ + +chatMsg :: + Identifier {- ^ channel -} -> + Text {- ^ nickname -} -> + Text {- ^ message -} -> + IrcMsg +chatMsg chan nick msg = + Privmsg + (userInfo nick) + chan + msg + +actionMsg :: + Identifier {- ^ channel -} -> + Text {- ^ nickname -} -> + Text {- ^ message -} -> + IrcMsg +actionMsg chan nick msg = + Ctcp + (userInfo nick) + chan + "ACTION" + msg + +joinMsg :: + Identifier {- ^ channel -} -> + Text {- ^ server -} -> + Text {- ^ nickname -} -> + Text {- ^ username -} -> + Text {- ^ hostname -} -> + IrcMsg +joinMsg chan srv nick user host = + Join + (Source (UserInfo (mkId (nick <> "@" <> srv)) user host) "") + chan + "" -- account + "" -- gecos + +partMsg :: + Identifier {- ^ channel -} -> + Text {- ^ server -} -> + Text {- ^ nickname -} -> + Text {- ^ reason wrapper -} -> + Text {- ^ reason -} -> + IrcMsg +partMsg chan srv nick msg_outer msg = + Part + (userInfo (nick <> "@" <> srv)) + chan + (if Text.null msg_outer then Nothing else Just msg) + +quitMsg :: + Text {- ^ server -} -> + Text {- ^ nickname -} -> + Text {- ^ quit message -} -> + IrcMsg +quitMsg srv nick msg = + Quit + (userInfo (nick <> "@" <> srv)) + (Just msg) + +nickMsg :: + Text {- ^ server -} -> + Text {- ^ old nick -} -> + Text {- ^ new nick -} -> + IrcMsg +nickMsg srv old new = + Nick + (userInfo (old <> "@" <> srv)) + (mkId (new <> "@" <> srv)) + +kickMsg :: + Identifier {- ^ channel -} -> + Text {- ^ server -} -> + Text {- ^ kickee nick -} -> + Text {- ^ kicker nick -} -> + Text {- ^ reason -} -> + IrcMsg +kickMsg chan srv kickee kicker reason = + Kick + (userInfo (kicker <> "@" <> srv)) + chan + (mkId (kickee <> "@" <> srv)) + reason + +modeMsg :: + Identifier {- ^ channel -} -> + Text {- ^ server -} -> + Text {- ^ nickname -} -> + Text {- ^ modes -} -> + IrcMsg +modeMsg chan srv nick modes = + Mode + (userInfo (nick <> "@" <> srv)) + chan + (Text.words modes) + +-- | Construct dummy user info when we don't know the user or host part. +userInfo :: + Text {- ^ nickname -} -> + Source +userInfo nick = Source (UserInfo (mkId nick) "*" "*") "" + +------------------------------------------------------------------------ + +-- | The class allows n-ary functions of the form +-- `Text -> Text -> ... -> IrcMsg` to be used to exhaustively consume the +-- matched elements of a regular expression. +class Rule a where + matchRule :: [Text] -> a -> Maybe IrcMsg + +instance (RuleArg a, Rule b) => Rule (a -> b) where + matchRule tts f = + do (t,ts) <- uncons tts + a <- matchArg t + matchRule ts (f a) + +instance Rule IrcMsg where + matchRule args ircMsg + | null args = Just ircMsg + | otherwise = Nothing + +class RuleArg a where matchArg :: Text -> Maybe a +instance RuleArg Text where matchArg = Just diff --git a/src/Client/Hook/FreRelay.hs b/src/Client/Hook/FreRelay.hs deleted file mode 100644 --- a/src/Client/Hook/FreRelay.hs +++ /dev/null @@ -1,216 +0,0 @@ -{-# Language QuasiQuotes, OverloadedStrings #-} -{-| -Module : Client.Hook.FreRelay -Description : Hook for interpreting FreFrelay messages -Copyright : (c) Eric Mertens 2019 -License : ISC -Maintainer : emertens@gmail.com - -The #dronebl channel uses the FreRelay bot to relay messages from -other networks. This hook integrates those messages into the native -format. - --} -module Client.Hook.FreRelay - ( freRelayHook - ) 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) - --- | Hook for mapping frerelay messages in #dronebl on freenode --- to appear like native messages. -freRelayHook :: [Text] -> Maybe MessageHook -freRelayHook args = Just (MessageHook "frerelay" False (remap (map mkId args))) - --- | Remap messages from frerelay on #dronebl that match one of the --- rewrite rules. -remap :: [Identifier] -> IrcMsg -> MessageResult -remap nicks (Privmsg (UserInfo nick _ _) chan@"#dronebl" msg) - | nick `elem` nicks - , Just sub <- rules chan msg = RemapMessage sub -remap _ _ = PassMessage - --- | Generate a replacement message for a chat message from frerelay --- when the message matches one of the replacement rules. -rules :: - Identifier {- ^ channel -} -> - Text {- ^ message -} -> - Maybe IrcMsg -rules chan msg = - asum - [ rule (chatMsg chan) chatRe msg - , rule (actionMsg chan) actionRe msg - , rule (joinMsg chan) joinRe msg - , rule (partMsg chan) partRe msg - , rule quitMsg quitRe msg - , rule nickMsg nickRe msg - , rule (kickMsg chan) kickRe msg - , rule (modeMsg chan) modeRe msg - ] - --- | Match the message against the regular expression and use the given --- consume to consume all of the captured groups. -rule :: - Rule r => - r {- ^ capture consumer -} -> - Regex {- ^ regular expression -} -> - Text {- ^ message -} -> - Maybe IrcMsg -rule mk re s = - case map (map Text.pack) (match re (Text.unpack s)) of - [_:xs] -> matchRule xs mk - _ -> Nothing - -chatRe, actionRe, joinRe, quitRe, nickRe, partRe, kickRe, modeRe :: Regex -Right chatRe = compRe [str|^<([^>]+)> (.*)$|] -Right actionRe = compRe [str|^\* ([^ ]+) (.*)$|] -Right joinRe = compRe [str|^\*\*\* \[([^]]+)\] ([^ ]+) \(([^@]+)@([^)]+)\) has joined the channel$|] -Right quitRe = compRe [str|^\*\*\* \[([^]]+)\] ([^ ]+) has signed off \((.*)\)$|] -Right nickRe = compRe [str|^\*\*\* \[([^]]+)\] ([^ ]+) changed nick to ([^ ]+)$|] -Right partRe = compRe [str|^\*\*\* \[([^]]+)\] ([^ ]+) has left the channel( \((.*)\))?$|] -Right kickRe = compRe [str|^\*\*\* \[([^]]+)\] ([^ ]+) has been kicked by ([^ ]+) \((.*)\)$|] -Right modeRe = compRe [str|^\*\*\* \[([^]]+)\] ([^ ]+) sets mode (.*)$|] - --- | Compile a regular expression for using in message matching. -compRe :: - Text {- ^ regular expression -} -> - Either String Regex {- ^ error or compiled expression -} -compRe = compile defaultCompOpt defaultExecOpt . Text.unpack - ------------------------------------------------------------------------- - -chatMsg :: - Identifier {- ^ channel -} -> - Text {- ^ nickname -} -> - Text {- ^ message -} -> - IrcMsg -chatMsg chan nick msg = - Privmsg - (userInfo nick) - chan - msg - -actionMsg :: - Identifier {- ^ channel -} -> - Text {- ^ nickname -} -> - Text {- ^ message -} -> - IrcMsg -actionMsg chan nick msg = - Ctcp - (userInfo nick) - chan - "ACTION" - msg - -joinMsg :: - Identifier {- ^ channel -} -> - Text {- ^ server -} -> - Text {- ^ nickname -} -> - Text {- ^ username -} -> - Text {- ^ hostname -} -> - IrcMsg -joinMsg chan srv nick user host = - Join - (UserInfo (mkId (nick <> "@" <> srv)) user host) - chan - "" -- account - "" -- gecos - -partMsg :: - Identifier {- ^ channel -} -> - Text {- ^ server -} -> - Text {- ^ nickname -} -> - Text {- ^ reason wrapper -} -> - Text {- ^ reason -} -> - IrcMsg -partMsg chan srv nick msg_outer msg = - Part - (userInfo (nick <> "@" <> srv)) - chan - (if Text.null msg_outer then Nothing else Just msg) - -quitMsg :: - Text {- ^ server -} -> - Text {- ^ nickname -} -> - Text {- ^ quit message -} -> - IrcMsg -quitMsg srv nick msg = - Quit - (userInfo (nick <> "@" <> srv)) - (Just msg) - -nickMsg :: - Text {- ^ server -} -> - Text {- ^ old nick -} -> - Text {- ^ new nick -} -> - IrcMsg -nickMsg srv old new = - Nick - (userInfo (old <> "@" <> srv)) - (mkId (new <> "@" <> srv)) - -kickMsg :: - Identifier {- ^ channel -} -> - Text {- ^ server -} -> - Text {- ^ kickee nick -} -> - Text {- ^ kicker nick -} -> - Text {- ^ reason -} -> - IrcMsg -kickMsg chan srv kickee kicker reason = - Kick - (userInfo (kicker <> "@" <> srv)) - chan - (mkId (kickee <> "@" <> srv)) - reason - -modeMsg :: - Identifier {- ^ channel -} -> - Text {- ^ server -} -> - Text {- ^ nickname -} -> - Text {- ^ modes -} -> - IrcMsg -modeMsg chan srv nick modes = - Mode - (userInfo (nick <> "@" <> srv)) - chan - (Text.words modes) - --- | Construct dummy user info when we don't know the user or host part. -userInfo :: - Text {- ^ nickname -} -> - UserInfo -userInfo nick = UserInfo (mkId nick) "*" "*" - ------------------------------------------------------------------------- - --- | The class allows n-ary functions of the form --- `Text -> Text -> ... -> IrcMsg` to be used to exhaustively consume the --- matched elements of a regular expression. -class Rule a where - matchRule :: [Text] -> a -> Maybe IrcMsg - -instance (RuleArg a, Rule b) => Rule (a -> b) where - matchRule tts f = - do (t,ts) <- uncons tts - a <- matchArg t - matchRule ts (f a) - -instance Rule IrcMsg where - matchRule args ircMsg - | null args = Just ircMsg - | otherwise = Nothing - -class RuleArg a where matchArg :: Text -> Maybe a -instance RuleArg Text where matchArg = Just diff --git a/src/Client/Hook/Matterbridge.hs b/src/Client/Hook/Matterbridge.hs new file mode 100644 --- /dev/null +++ b/src/Client/Hook/Matterbridge.hs @@ -0,0 +1,69 @@ +{-# Language OverloadedStrings #-} +{-| +Module : Client.Hook.Matterbridge +Description : Hook for intergrating Matterbridge bridged messages +Copyright : (c) Felix Friedlander 2021 +License : ISC +Maintainer : felix@ffetc.net + +Matterbridge is a simple multi-protocol chat bridge, supporting +dozens of different protocols. This hook makes Matterbridged messages +appear native in the client. + +message-hooks configuration takes one of two forms; +to operate on all channels: + +> ["matterbridge", "nick"] + +or, to operate only on selected channels: + +> ["matterbridge", "nick", "#chan1", "#chan2", ..., "#chann"] + +This hook assumes the Matterbridge RemoteNickFormat is simply +"<{NICK}> ". + +-} +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 Irc.Identifier (mkId, Identifier) +import Irc.UserInfo (UserInfo(..), uiNick) + +data MbMsg = Msg | Act + +matterbridgeHook :: [Text] -> Maybe MessageHook +matterbridgeHook [] = Nothing +matterbridgeHook (nick:chans) = Just (MessageHook "matterbridge" False (remap (mkId nick) chanfilter)) + where + chanfilter + | null chans = const True + | otherwise = (`elem` map mkId chans) + +remap :: Identifier -> (Identifier -> Bool) -> IrcMsg -> MessageResult +remap nick chanfilter ircmsg = + case ircmsg of + Privmsg (Source ui _) chan msg + | view uiNick ui == nick, chanfilter chan -> remap' Msg ui chan msg + Ctcp (Source ui _) chan "ACTION" msg + | view uiNick ui == nick, chanfilter chan -> remap' Act ui chan msg + _ -> PassMessage + +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 + +newmsg :: MbMsg -> Source -> Identifier -> Text -> IrcMsg +newmsg Msg src chan msg = Privmsg src chan msg +newmsg Act src chan msg = Ctcp src chan "ACTION" msg + +fakeUser :: Text -> UserInfo -> Source +fakeUser nick ui = Source (set uiNick (mkId nick) ui) "" 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 @@ -6,8 +6,7 @@ License : ISC Maintainer : emertens@gmail.com -These sorting rules are based on the kinds of messages that freenode's -ircd-seven sends. +These sorting rules are based on the solanum server notices. -} module Client.Hook.Snotice @@ -32,12 +31,12 @@ remap :: IrcMsg -> MessageResult -remap (Notice (UserInfo u "" "") _ msg) +remap (Notice (Source (UserInfo u "" "") _) _ msg) | Just msg1 <- Text.stripPrefix "*** Notice -- " msg , let msg2 = Text.filter (\x -> x /= '\x02' && x /= '\x0f') msg1 , Just (lvl, cat) <- characterize msg2 = if lvl < 1 then OmitMessage - else RemapMessage (Notice (UserInfo u "" "*") cat msg1) + else RemapMessage (Notice (Source (UserInfo u "" "*") "") cat msg1) remap _ = PassMessage @@ -73,16 +72,14 @@ -- Nick change (0, "c", [str|^Nick change: From |]), -- Connection limit, more complete regex: ^Too many user connections for [^ ]+![^ ]+@[^ ]+$ - (0, "u", [str|^Too many user connections for |]), + (1, "u", [str|^Too many user connections for |]), -- Join alerts, more complete regex: ^User [^ ]+ \([^ ]+@[^ ]+\) trying to join #[^ ]* is a possible spambot$ (1, "a", [str|^User [^ ]+ \([^ ]+\) trying to join #[^ ]* is a possible spambot|]), -- Kline hitting user (1, "k", [str|^K/DLINE active for|]), -- Connection limit, more complete regex: ^Too many local connections for [^ ]+![^ ]+@[^ ]+$ - (0, "u", [str|^Too many local connections for |]), + (1, "u", [str|^Too many local connections for |]), -- Global kline added, more complete regex: ^[^ ]+![^ ]+@[^ ]+\{[^ ]+\} added global [0-9]+ min. K-Line for \[[^ ]+\] \[.*\]$ - (1, "k", [str|^[^ @]+@freenode/utility-bot/sigyn\{[^ ]+ added global [0-9]+ min. K-Line for |]), - (1, "k", [str|^[^ @]+@freenode/bot/proxyscan\{[^ ]+ added global [0-9]+ min. K-Line for |]), (2, "k", [str|^[^ ]+ added global [0-9]+ min. K-Line for |]), (2, "k", [str|^[^ ]+ added global [0-9]+ min. X-Line for |]), -- Global kline expiring, more complete regex: ^Propagated ban for \[[^ ]+\] expired$ @@ -103,10 +100,8 @@ (1, "m", [str|^Nick collision on|]), -- KILLs (0, "k", [str|^Received KILL message for [^ ]+\. From NickServ |]), - (0, "k", [str|^Received KILL message for [^ ]+\. From [^ .]+\.freenode\.net \(Nickname regained by services\)|]), (0, "k", [str|^Received KILL message for [^ ]+\. From syn Path: [^ ]+ \(Facility Blocked\)|]), (1, "k", [str|^Received KILL message for [^ ]+\. From syn Path: [^ ]+ \(Banned\)|]), - (1, "k", [str|^Received KILL message for [^ ]+\. From Sigyn Path: [^ ]+ \(Spam is off topic on freenode\.\)|]), (2, "k", [str|^Received KILL message|]), -- Teporary kline expiring, more complete regex: ^Temporary K-line for \[[^ ]+\] expired$ (0, "k", [str|^Temporary K-line for |]), @@ -114,10 +109,13 @@ -- PATTERN LIST, uncommon snotes. regex performance isn't very important beyond this point (2, "a", [str|^Possible Flooder|]), (0, "a", [str|^New Max Local Clients: [0-9]+$|]), + (1, "a", [str|^Excessive target change from|]), (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|^KLINE active for|]), (1, "k", [str|^XLINE active for|]), (3, "k", [str|^KLINE over-ruled for |]), @@ -128,6 +126,7 @@ (2, "k", [str|^[^ ]+![^ ]+@[^ ]+\{[^ ]+\} added temporary [0-9]+ min. D-Line for \[[^ ]+\] \[.*\]$|]), (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:|]), (0, "m", [str|^Received SAVE message for|]), (0, "m", [str|^Ignored noop SAVE message for|]), @@ -149,6 +148,7 @@ (2, "o", [str|^OPERSPY [^ ]+![^ ]+@[^ ]+\{[^ ]+\} |]), (2, "o", [str|^[^ ]+![^ ]+@[^ ]+\{[^ ]+\} is overriding |]), + (2, "o", [str|^[^ ]+![^ ]+@[^ ]+\{[^ ]+\} is using oper-override on |]), (2, "o", [str|^[^ ]+ \([^ ]+@[^ ]+\) is now an operator$|]), (1, "o", [str|^[^ ]+( \([^ ]+\))? dropped the nick |]), (1, "o", [str|^[^ ]+( \([^ ]+\))? dropped the account |]), @@ -211,7 +211,7 @@ (3, "o", [str|^ERROR |]), (3, "o", [str|^No response from [^ ]+, closing link$|]), - (0, "u", [str|^Too many global connections for [^ ]+![^ ]+@[^ ]+$|]), + (1, "u", [str|^Too many global connections for [^ ]+![^ ]+@[^ ]+$|]), (0, "u", [str|^Invalid username: |]), (0, "u", [str|^HTTP Proxy disconnected: |]), (2, "u", [str|^Unauthorised client connection from |]), 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 @@ -40,11 +40,11 @@ Bool {- ^ enable debugging -} -> IrcMsg -> MessageResult remap debug (Privmsg user chan msg) - | userNick user == "*buffextras" + | userNick (srcUser user) == "*buffextras" , Right newMsg <- parseOnly (prefixedParser chan) msg = RemapMessage newMsg - | userNick user == "*buffextras" + | userNick (srcUser user) == "*buffextras" , not debug = OmitMessage @@ -53,14 +53,15 @@ prefixedParser :: Identifier -> Parser IrcMsg prefixedParser chan = do pfx <- prefixParser + let src = Source pfx "" choice - [ Join pfx chan "" "" <$ skipToken "joined" - , Quit pfx . filterEmpty <$ skipToken "quit:" <*> P.takeText - , Part pfx chan . filterEmpty <$ skipToken "parted:" <*> P.takeText - , Nick pfx . mkId <$ skipToken "is now known as" <*> simpleTokenParser - , Mode pfx chan <$ skipToken "set mode:" <*> allTokens - , Kick pfx chan <$ skipToken "kicked" <*> parseId <* skipToken "with reason:" <*> P.takeText - , Topic pfx chan <$ skipToken "changed the topic to:" <*> P.takeText + [ Join src chan "" "" <$ skipToken "joined" + , Quit src . filterEmpty <$ skipToken "quit:" <*> P.takeText + , Part src chan . filterEmpty <$ skipToken "parted:" <*> P.takeText + , Nick src . mkId <$ skipToken "is now known as" <*> simpleTokenParser + , Mode src chan <$ skipToken "set mode:" <*> allTokens + , Kick src chan <$ skipToken "kicked" <*> parseId <* skipToken "with reason:" <*> P.takeText + , Topic src chan <$ skipToken "changed the topic to:" <*> P.takeText ] allTokens :: Parser [Text] diff --git a/src/Client/Hooks.hs b/src/Client/Hooks.hs --- a/src/Client/Hooks.hs +++ b/src/Client/Hooks.hs @@ -19,14 +19,16 @@ import Data.HashMap.Strict import Client.Hook -import Client.Hook.FreRelay +import Client.Hook.DroneBLRelay +import Client.Hook.Matterbridge import Client.Hook.Snotice import Client.Hook.Znc.Buffextras -- | All the available message hooks. messageHooks :: HashMap Text ([Text] -> Maybe MessageHook) messageHooks = fromList - [ ("snotice" , \_ -> Just snoticeHook) - , ("frerelay" , freRelayHook) + [ ("snotice", \_ -> Just snoticeHook) + , ("droneblrelay", droneblRelayHook) , ("buffextras", buffextrasHook) + , ("matterbridge", matterbridgeHook) ] 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 @@ -38,6 +38,7 @@ import Client.Message import Client.State.Window import Client.UserHost +import Control.Applicative ((<|>)) import Control.Lens import Data.Char import Data.Hashable (hash) @@ -155,8 +156,8 @@ case body of IrcBody irc | NormalRender <- rm -> ircLineImage params irc | DetailedRender <- rm -> fullIrcLineImage params irc - ErrorBody txt -> parseIrcText txt - NormalBody txt -> parseIrcText txt + ErrorBody txt -> parseIrcText (rendPalette params) txt + NormalBody txt -> parseIrcText (rendPalette params) txt -- | Render a 'ZonedTime' as time using quiet attributes -- @@ -214,18 +215,20 @@ who n = string (view palSigil pal) sigils <> ui where - baseUI = coloredUserInfo pal rm hilites n + baseUI = coloredUserInfo pal rm hilites (srcUser n) ui = case rendAccounts rp of Nothing -> baseUI -- not tracking any accounts Just accts -> - let isKnown acct = not (Text.null acct || acct == "*") - mbAcct = accts - ^? ix (userNick n) + let tagAcct = if Text.null (srcAcct n) then Nothing else Just (srcAcct n) + + isKnown acct = not (Text.null acct || acct == "*") + lkupAcct = accts + ^? ix (userNick (srcUser n)) . uhAccount . filtered isKnown in - case mbAcct of + case tagAcct <|> lkupAcct of Just acct - | mkId acct == userNick n -> baseUI + | mkId acct == userNick (srcUser n) -> baseUI | otherwise -> baseUI <> "(" <> ctxt acct <> ")" Nothing -> "~" <> baseUI in @@ -240,6 +243,7 @@ -- details in message part Topic src _ _ -> who src Kick src _ _ _ -> who src + Kill src _ _ -> who src Mode src _ _ -> who src Invite src _ _ -> who src @@ -263,8 +267,8 @@ Reply _ code _ -> replyCodePrefix code UnknownMsg irc -> - case view msgPrefix irc of - Just ui -> who ui + case msgSource irc of + Just src -> who src Nothing -> string (view palError pal) "?" Cap cmd -> @@ -298,7 +302,7 @@ Nick {} -> mempty Authenticate{} -> "***" - Error txt -> parseIrcText txt + Error txt -> parseIrcText pal txt Topic _ _ txt -> "changed the topic: " <> parseIrcTextWithNicks pal hilites False txt @@ -309,24 +313,30 @@ ": " <> parseIrcTextWithNicks pal hilites False reason + Kill _who killee reason -> + "killed " <> + coloredIdentifier pal NormalIdentifier hilites killee <> + ": " <> + parseIrcTextWithNicks pal hilites False reason + Notice _ _ txt -> parseIrcTextWithNicks pal hilites False txt Privmsg _ _ txt -> parseIrcTextWithNicks pal hilites False txt Wallops _ txt -> parseIrcTextWithNicks pal hilites False txt Ctcp _ _ "ACTION" txt -> parseIrcTextWithNicks pal hilites False txt Ctcp {} -> mempty - CtcpNotice _ _ cmd txt -> parseIrcText cmd <> " " <> + CtcpNotice _ _ cmd txt -> parseIrcText pal cmd <> " " <> parseIrcTextWithNicks pal hilites False txt Reply srv code params -> renderReplyCode pal NormalRender srv code params UnknownMsg irc -> ctxt (view msgCommand irc) <> char defAttr ' ' <> - separatedParams (view msgParams irc) + separatedParams pal (view msgParams irc) Cap cmd -> ctxt (capCmdText cmd) Mode _ _ params -> "set mode: " <> - ircWords params + ircWords pal params Invite _ tgt chan -> "invited " <> @@ -355,9 +365,10 @@ string (view palSigil pal) sigils <> -- nick!user@host - plainWho n <> + plainWho (srcUser n) <> - case rendAccounts rp ^? folded . ix (userNick n) . uhAccount of + case rendAccounts rp ^? folded . ix (userNick (srcUser n)) . uhAccount of + _ | not (Text.null (srcAcct n)) -> text' quietAttr ("(" <> cleanText (srcAcct n) <> ")") Just acct | not (Text.null acct) -> text' quietAttr ("(" <> cleanText acct <> ")") _ -> "" @@ -371,12 +382,13 @@ Join nick _chan acct gecos -> string quietAttr "join " <> - plainWho nick <> + plainWho (srcUser nick) <> accountPart <> gecosPart where accountPart - | Text.null acct = mempty - | otherwise = text' quietAttr ("(" <> cleanText acct <> ")") + | not (Text.null (srcAcct nick)) = text' quietAttr ("(" <> cleanText (srcAcct nick) <> ")") + | not (Text.null acct) = text' quietAttr ("(" <> cleanText acct <> ")") + | otherwise = mempty gecosPart | Text.null gecos = mempty | otherwise = text' quietAttr (" [" <> cleanText gecos <> "]") @@ -385,14 +397,14 @@ string quietAttr "part " <> who nick <> foldMap (\reason -> string quietAttr " (" <> - parseIrcText reason <> + parseIrcText pal reason <> string quietAttr ")") mbreason Quit nick mbreason -> string quietAttr "quit " <> who nick <> foldMap (\reason -> string quietAttr " (" <> - parseIrcText reason <> + parseIrcText pal reason <> string quietAttr ")") mbreason Kick kicker _channel kickee reason -> @@ -401,13 +413,21 @@ " kicked " <> coloredIdentifier pal NormalIdentifier hilites kickee <> ": " <> - parseIrcText reason + parseIrcText pal reason + Kill killer killee reason -> + string quietAttr "kill " <> + who killer <> + " killed " <> + coloredIdentifier pal NormalIdentifier hilites killee <> + ": " <> + parseIrcText pal reason + Topic src _dst txt -> string quietAttr "tpic " <> who src <> " changed the topic: " <> - parseIrcText txt + parseIrcText pal txt Invite src tgt chan -> string quietAttr "invt " <> @@ -443,25 +463,25 @@ string quietAttr "ctcp " <> string (withForeColor defAttr blue) "! " <> who src <> " " <> - parseIrcText cmd <> - if Text.null txt then mempty else separatorImage <> parseIrcText txt + parseIrcText pal cmd <> + if Text.null txt then mempty else separatorImage <> parseIrcText pal txt CtcpNotice src _dst cmd txt -> string quietAttr "ctcp " <> string (withForeColor defAttr red) "! " <> who src <> " " <> - parseIrcText cmd <> - if Text.null txt then mempty else separatorImage <> parseIrcText txt + parseIrcText pal cmd <> + if Text.null txt then mempty else separatorImage <> parseIrcText pal txt Ping params -> - "PING " <> separatedParams params + "PING " <> separatedParams pal params Pong params -> - "PONG " <> separatedParams params + "PONG " <> separatedParams pal params Error reason -> string (view palError pal) "ERROR " <> - parseIrcText reason + parseIrcText pal reason Reply srv code params -> renderReplyCode pal DetailedRender srv code params @@ -471,7 +491,7 @@ (view msgPrefix irc) <> ctxt (view msgCommand irc) <> char defAttr ' ' <> - separatedParams (view msgParams irc) + separatedParams pal (view msgParams irc) Cap cmd -> text' (withForeColor defAttr magenta) (renderCapCmd cmd) <> @@ -481,7 +501,7 @@ Mode nick _chan params -> string quietAttr "mode " <> who nick <> " set mode: " <> - ircWords params + ircWords pal params Authenticate{} -> "AUTHENTICATE ***" BatchStart{} -> "BATCH +" @@ -514,12 +534,12 @@ -- | Process list of 'Text' as individual IRC formatted words -- separated by a special separator to distinguish parameters -- from words within parameters. -separatedParams :: [Text] -> Image' -separatedParams = mconcat . intersperse separatorImage . map parseIrcText +separatedParams :: Palette -> [Text] -> Image' +separatedParams pal = mconcat . intersperse separatorImage . map (parseIrcText pal) -- | Process list of 'Text' as individual IRC formatted words -ircWords :: [Text] -> Image' -ircWords = mconcat . intersperse (char defAttr ' ') . map parseIrcText +ircWords :: Palette -> [Text] -> Image' +ircWords pal = mconcat . intersperse (char defAttr ' ') . map (parseIrcText pal) replyCodePrefix :: ReplyCode -> Image' replyCodePrefix code = text' attr (replyCodeText info) <> ":" @@ -581,6 +601,7 @@ RPL_GLOBALUSERS -> lusersParamsImage RPL_LUSEROP -> params_2_3_Image RPL_LUSERCHANNELS-> params_2_3_Image + RPL_LUSERUNKNOWN -> params_2_3_Image RPL_ENDOFSTATS -> params_2_3_Image RPL_AWAY -> awayParamsImage RPL_TRACEUSER -> traceUserParamsImage @@ -598,17 +619,21 @@ RPL_LIST -> listParamsImage RPL_LINKS -> linksParamsImage RPL_ENDOFLINKS -> params_2_3_Image + RPL_PRIVS -> privsImage + RPL_LOGGEDIN -> loggedInImage ERR_NOPRIVS -> params_2_3_Image ERR_HELPNOTFOUND -> params_2_3_Image ERR_NEEDMOREPARAMS -> params_2_3_Image ERR_NOSUCHNICK -> params_2_3_Image ERR_NOSUCHSERVER -> params_2_3_Image + ERR_NICKNAMEINUSE -> params_2_3_Image + ERR_MLOCKRESTRICTED -> mlockRestrictedImage _ -> rawParamsImage where label t = text' (view palLabel pal) t <> ": " - rawParamsImage = separatedParams params' + rawParamsImage = separatedParams pal params' params' = case rm of DetailedRender -> params @@ -662,7 +687,7 @@ text' (view palLabel pal) "@" <> ctxt host <> label " gecos" <> - parseIrcText' False real + parseIrcText' False pal real _ -> rawParamsImage whoisIdleParamsImage = @@ -676,9 +701,9 @@ whoisServerParamsImage = case params of [_, _, host, txt] -> - parseIrcText' False host <> + parseIrcText' False pal host <> label " note" <> - parseIrcText' False txt + parseIrcText' False pal txt _ -> rawParamsImage testlineParamsImage = @@ -706,6 +731,18 @@ authLineParamsImage = case params of + [_, "I", name, pass, mask, port, klass, note] -> + ctxt name <> + (if pass == "" then mempty else label " pass" <> ctxt pass) <> + label " mask" <> ctxt mask' <> + (if port == "0" then mempty else label " port" <> ctxt port) <> + label " class" <> ctxt klass <> + (if null special then mempty else + label " special" <> ctxt (Text.unwords special)) <> + (if Text.null note then mempty else + label " note" <> ctxt note) + where + (mask', special) = parseILinePrefix mask [_, "I", name, pass, mask, port, klass] -> ctxt name <> (if pass == "" then mempty else label " pass" <> ctxt pass) <> @@ -748,7 +785,7 @@ case params of [_, flag, host, reason] -> ctxt flag <> - label " host:" <> ctxt host <> + label " host" <> ctxt host <> label " reason" <> ctxt reason _ -> rawParamsImage @@ -841,7 +878,7 @@ awayParamsImage = case params of - [_, nick, txt] -> ctxt nick <> label " msg" <> parseIrcText txt + [_, nick, txt] -> ctxt nick <> label " msg" <> parseIrcText pal txt _ -> rawParamsImage listParamsImage = @@ -959,6 +996,33 @@ label " p2" <> ctxt p2 _ -> rawParamsImage + loggedInImage = + case params of + [_, mask, account, _txt] -> + ctxt mask <> + label " account" <> ctxt account + _ -> rawParamsImage + + privsImage = + case params of + [_, target, list] -> + case Text.stripPrefix "* " list of + Nothing -> + ctxt target <> + label " end" <> ctxt list + Just list' -> + ctxt target <> + label " ..." <> ctxt list' + _ -> rawParamsImage + + mlockRestrictedImage = + case params of + [_, chan, mode, mlock, _] -> + ctxt chan <> + label " mode" <> ctxt mode <> + label " mlock" <> ctxt mlock + _ -> rawParamsImage + parseCLineFlags :: Text -> [Text] parseCLineFlags = go [] where @@ -992,6 +1056,7 @@ '-' -> Just "no-tilde" '+' -> Just "need-ident" '=' -> Just "spoof-IP" + '%' -> Just "need-sasl" '|' -> Just "flood-exempt" '$' -> Just "dnsbl-exempt" '^' -> Just "kline-exempt" @@ -1094,7 +1159,7 @@ Text {- ^ input text -} -> Image' {- ^ colored text -} parseIrcTextWithNicks palette hilite explicit txt - | Text.any isControl txt = parseIrcText' explicit txt + | Text.any isControl txt = parseIrcText' explicit palette txt | otherwise = highlightNicks palette hilite txt -- | Given a list of nicknames and a chat message, this will generate @@ -1120,7 +1185,7 @@ metadataImg :: IrcSummary -> Maybe (Image', Identifier, Maybe Identifier) metadataImg msg = case msg of - QuitSummary who -> Just (char (withForeColor defAttr red ) 'x', who, Nothing) + 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) @@ -1128,6 +1193,8 @@ ChngSummary who -> Just (char (withForeColor defAttr blue ) '*', who, Nothing) AcctSummary who -> Just (char (withForeColor defAttr blue ) '*', who, Nothing) _ -> Nothing + + -- | Image used when treating ignored chat messages as metadata ignoreImage :: Image' 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 @@ -20,6 +20,7 @@ ) 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 @@ -39,15 +40,16 @@ ''Attr -- | Parse mIRC encoded format characters and hide the control characters. -parseIrcText :: Text -> Image' +parseIrcText :: Palette -> Text -> Image' parseIrcText = parseIrcText' False -- | Parse mIRC encoded format characters and render the control characters -- explicitly. This view is useful when inputting control characters to make -- it clear where they are in the text. -parseIrcText' :: Bool -> Text -> Image' -parseIrcText' explicit = either plainText id - . parseOnly (pIrcLine explicit defAttr) +parseIrcText' :: Bool -> Palette -> Text -> Image' +parseIrcText' explicit pal + = either plainText id + . parseOnly (pIrcLine pal explicit False defAttr) data Segment = TextSegment Text | ControlSegment Char @@ -55,17 +57,17 @@ pSegment = TextSegment <$> takeWhile1 (not . isControl) <|> ControlSegment <$> satisfy isControl -pIrcLine :: Bool -> Attr -> Parser Image' -pIrcLine explicit fmt = +pIrcLine :: Palette -> Bool -> Bool -> Attr -> Parser Image' +pIrcLine pal explicit mono fmt = do seg <- option Nothing (Just <$> pSegment) case seg of Nothing -> return mempty Just (TextSegment txt) -> - do rest <- pIrcLine explicit fmt + do rest <- pIrcLine pal explicit mono fmt return (text' fmt txt <> rest) Just (ControlSegment '\^C') -> do (numberText, colorNumbers) <- match (pColorNumbers pColorNumber) - rest <- pIrcLine explicit (applyColors colorNumbers fmt) + rest <- pIrcLine pal explicit mono (applyColors colorNumbers fmt) return $ if explicit then controlImage '\^C' <> text' defAttr numberText @@ -73,12 +75,18 @@ else rest Just (ControlSegment '\^D') -> do (numberText, colorNumbers) <- match (pColorNumbers pColorHex) - rest <- pIrcLine explicit (applyColors colorNumbers fmt) + rest <- pIrcLine pal explicit mono (applyColors colorNumbers fmt) return $ if explicit then controlImage '\^D' <> text' defAttr numberText <> rest else rest + Just (ControlSegment '\^Q') + | explicit -> (controlImage '\^Q' <>) <$> rest + | otherwise -> rest + where + rest = pIrcLine pal explicit (not mono) + (if mono then defAttr else view palMonospace pal) Just (ControlSegment c) -- always render control codes that we don't understand | isNothing mbFmt' || explicit -> @@ -87,7 +95,7 @@ | otherwise -> next where mbFmt' = applyControlEffect c fmt - next = pIrcLine explicit (fromMaybe fmt mbFmt') + next = pIrcLine pal explicit mono (fromMaybe fmt mbFmt') pColorNumbers :: Parser (MaybeDefault Color) -> 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 @@ -39,6 +39,7 @@ , palUModes , palSnomask , palAway + , palMonospace , paletteMap @@ -77,6 +78,7 @@ , _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 , _palUModes :: HashMap Char Attr -- ^ user mode attributes , _palSnomask :: HashMap Char Attr -- ^ snotice mask attributes @@ -110,6 +112,7 @@ , _palWindowDivider = withStyle defAttr reverseVideo , _palLineMarker = defAttr , _palAway = withForeColor defAttr brightBlack + , _palMonospace = defAttr , _palCModes = HashMap.empty , _palUModes = HashMap.empty , _palSnomask = HashMap.empty @@ -148,4 +151,5 @@ , ("window-divider" , Lens palWindowDivider) , ("line-marker" , Lens palLineMarker) , ("away" , Lens palAway) + , ("monospace" , Lens palMonospace) ] 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 @@ -65,6 +65,7 @@ , nometaImage (view clientFocus st) st , scrollImage st , filterImage st + , lockImage st , latency ] @@ -126,6 +127,15 @@ filterImage st | clientIsFiltered st = infoBubble (string attr "filtered") | otherwise = mempty + where + pal = clientPalette st + attr = view palError pal + +-- | Indicate when the client editor is locked +lockImage :: ClientState -> Image' +lockImage st + | view clientEditLock st = infoBubble (string attr "locked") + | otherwise = mempty where pal = clientPalette st attr = view palError pal 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 @@ -64,7 +64,7 @@ curTxt = view Edit.text cur cursorBase - = imageWidth $ parseIrcText' True + = imageWidth $ parseIrcText' True pal $ Text.pack $ take (view Edit.pos cur) curTxt @@ -167,7 +167,7 @@ -- ["one","two"] "three" --> "two one three" leftLen = length leftImgs -- separators + sum (map imageWidth leftImgs) - + imageWidth (parseIrcText' True (Text.pack leftCur)) + + imageWidth (parseIrcText' True pal (Text.pack leftCur)) rndr = renderLine st pal hilites macros diff --git a/src/Client/Log.hs b/src/Client/Log.hs --- a/src/Client/Log.hs +++ b/src/Client/Log.hs @@ -69,11 +69,11 @@ IrcBody irc -> case irc of Privmsg who _ txt -> - success (L.fromChunks (statuspart ["<", idText (userNick who), "> ", cleanText txt])) + success (L.fromChunks (statuspart ["<", idText (userNick (srcUser who)), "> ", cleanText txt])) Notice who _ txt -> - success (L.fromChunks (statuspart ["-", idText (userNick who), "- ", cleanText txt])) + success (L.fromChunks (statuspart ["-", idText (userNick (srcUser who)), "- ", cleanText txt])) Ctcp who _ "ACTION" txt -> - success (L.fromChunks (statuspart ["* ", idText (userNick who), " ", cleanText txt])) + success (L.fromChunks (statuspart ["* ", idText (userNick (srcUser who)), " ", cleanText txt])) _ -> Nothing where diff --git a/src/Client/Message.hs b/src/Client/Message.hs --- a/src/Client/Message.hs +++ b/src/Client/Message.hs @@ -27,7 +27,11 @@ -- * Client message operations , IrcSummary(..) , msgSummary + , summaryActor + -- * Quit message details + , QuitKind(..) + -- * Client message operations , msgText ) where @@ -55,15 +59,19 @@ makeLenses ''ClientMessage +data QuitKind + = NormalQuit -- ^ User quit + | MassQuit -- ^ Mass event like a netsplit + deriving (Eq, Show) + data IrcSummary = JoinSummary {-# UNPACK #-} !Identifier - | QuitSummary {-# UNPACK #-} !Identifier + | QuitSummary {-# UNPACK #-} !Identifier !QuitKind | PartSummary {-# UNPACK #-} !Identifier | NickSummary {-# UNPACK #-} !Identifier {-# UNPACK #-} !Identifier | ReplySummary {-# UNPACK #-} !ReplyCode | ChatSummary {-# UNPACK #-} !UserInfo | CtcpSummary {-# UNPACK #-} !Identifier - | DccSendSummary {-# UNPACK #-} !Identifier | ChngSummary {-# UNPACK #-} !Identifier -- ^ Chghost command | AcctSummary {-# UNPACK #-} !Identifier -- ^ Account command | NoSummary @@ -86,16 +94,37 @@ ircSummary :: IrcMsg -> IrcSummary ircSummary msg = case msg of - Join who _ _ _ -> JoinSummary (userNick who) - Part who _ _ -> PartSummary (userNick who) - Quit who _ -> QuitSummary (userNick who) - Nick who who' -> NickSummary (userNick who) who' - Privmsg who _ _ -> ChatSummary who - Notice who _ _ -> ChatSummary who - Ctcp who _ "ACTION" _ -> ChatSummary who - Ctcp who _ _ _ -> CtcpSummary (userNick who) - CtcpNotice who _ _ _ -> ChatSummary who + Join who _ _ _ -> JoinSummary (userNick (srcUser who)) + Part who _ _ -> PartSummary (userNick (srcUser who)) + Quit who mbTxt -> QuitSummary (userNick (srcUser who)) (quitKind mbTxt) + Nick who who' -> NickSummary (userNick (srcUser who)) who' + Privmsg who _ _ -> ChatSummary (srcUser who) + Notice who _ _ -> ChatSummary (srcUser who) + Ctcp who _ "ACTION" _ -> ChatSummary (srcUser who) + Ctcp who _ _ _ -> CtcpSummary (userNick (srcUser who)) + CtcpNotice who _ _ _ -> ChatSummary (srcUser who) Reply _ code _ -> ReplySummary code - Account who _ -> AcctSummary (userNick who) - Chghost who _ _ -> ChngSummary (userNick who) + Account who _ -> AcctSummary (userNick (srcUser who)) + Chghost who _ _ -> ChngSummary (userNick (srcUser who)) _ -> NoSummary + +quitKind :: Maybe Text -> QuitKind +quitKind mbReason = + case mbReason of + Just "*.net *.split" -> MassQuit + _ -> NormalQuit + +summaryActor :: IrcSummary -> Maybe Identifier +summaryActor s = + case s of + JoinSummary who -> Just who + QuitSummary who _ -> Just who + PartSummary who -> Just who + NickSummary who _ -> Just who + ChatSummary who -> Just (userNick who) + CtcpSummary who -> Just who + AcctSummary who -> Just who + ChngSummary who -> Just who + ReplySummary {} -> Nothing + NoSummary -> Nothing + diff --git a/src/Client/Network/Connect.hs b/src/Client/Network/Connect.hs --- a/src/Client/Network/Connect.hs +++ b/src/Client/Network/Connect.hs @@ -34,7 +34,8 @@ , tpClientPrivateKey = view ssTlsClientKey ss <|> view ssTlsClientCert ss , tpServerCertificate = view ssTlsServerCert ss , tpCipherSuite = view ssTlsCiphers ss - , tpInsecure = not (view ssTlsVerify ss) + , tpCipherSuiteTls13 = view ssTls13Ciphers ss + , tpVerify = view ssTlsVerify ss , tpClientPrivateKeyPassword = case view ssTlsClientKeyPassword ss of Just (SecretText str) -> Just (Text.encodeUtf8 str) diff --git a/src/Client/Options.hs b/src/Client/Options.hs --- a/src/Client/Options.hs +++ b/src/Client/Options.hs @@ -39,7 +39,7 @@ import Data.Text (Text) import qualified Data.Text as Text import Data.Version -import Development.GitRev (gitHash, gitDirty) +import GitHash (giHash, giDirty, tGitInfoCwdTry) import System.Console.GetOpt import System.Environment import System.Exit @@ -136,9 +136,14 @@ versionTxt :: String versionTxt = unlines - [ "glirc-" ++ showVersion version ++ gitHashTxt ++ gitDirtyTxt + [ "glirc-" ++ showVersion version ++ gitHashTxt , "Copyright 2016-2020 Eric Mertens" ] + where + gitHashTxt = + case $$tGitInfoCwdTry of + Left{} -> "" + Right gi -> giHash gi ++ if giDirty gi then "-dirty" else "" fullVersionTxt :: String fullVersionTxt = @@ -158,19 +163,3 @@ :"Transitive dependencies:" : [ name ++ "-" ++ intercalate "." (map show ver) | (name,ver) <- sort deps ] ) - --- git version information --------------------------------------------- - --- | Returns @"-SOMEHASH"@ when in a git repository, @""@ otherwise. -gitHashTxt :: String -gitHashTxt - | hashTxt == "UNKNOWN" = "" - | otherwise = '-':hashTxt - where - hashTxt = $gitHash - --- | Returns @"-dirty"@ when in a dirty git repository, @""@ otherwise. -gitDirtyTxt :: String -gitDirtyTxt - | $gitDirty = "-dirty" - | otherwise = "" diff --git a/src/Client/State.hs b/src/Client/State.hs --- a/src/Client/State.hs +++ b/src/Client/State.hs @@ -44,6 +44,7 @@ , clientErrorMsg , clientLayout , clientEditMode + , clientEditLock , clientRtsStats , clientConfigPath , clientStsPolicy @@ -189,6 +190,7 @@ , _clientRegex :: Maybe Matcher -- ^ optional persistent filter , _clientLayout :: LayoutMode -- ^ layout mode for split screen , _clientEditMode :: EditMode -- ^ editor rendering mode + , _clientEditLock :: Bool -- ^ editor locked and won't send , _clientBell :: !Bool -- ^ sound a bell next draw @@ -277,6 +279,7 @@ , _clientRegex = Nothing , _clientLayout = view configLayout cfg , _clientEditMode = SingleLineEditor + , _clientEditLock = False , _clientActivityBar = view configActivityBar cfg , _clientShowPing = view configShowPing cfg , _clientBell = False @@ -411,8 +414,8 @@ | otherwise -> checkTxt txt Ctcp{} -> WLNormal Wallops{} -> WLImportant - Part who _ _ | isMe (userNick who) -> WLImportant - | otherwise -> WLBoring + Part who _ _ | isMe (userNick (srcUser who)) -> WLImportant + | otherwise -> WLBoring Kick _ _ kicked _ | isMe kicked -> WLImportant | otherwise -> WLNormal Error{} -> WLImportant @@ -443,8 +446,8 @@ _ -> Nothing where checkUser !who - | identIgnored who st = Just (userNick who) - | otherwise = Nothing + | identIgnored (srcUser who) st = Just (userNick (srcUser who)) + | otherwise = Nothing @@ -489,7 +492,7 @@ [Char] {- ^ sigils -} computeMsgLineSigils network channel msg st = case msgActor =<< preview (msgBody . _IrcBody) msg of - Just user -> computeUserSigils network channel (userNick user) st + Just user -> computeUserSigils network channel (userNick (srcUser user)) st Nothing -> [] -- | Compute sigils for a user on a channel @@ -868,7 +871,7 @@ $ over clientWindows moveWindow st | otherwise = st where - old' = userNick old + old' = userNick (srcUser old) mkFocus = ChannelFocus network diff --git a/src/Client/State/EditBox.hs b/src/Client/State/EditBox.hs --- a/src/Client/State/EditBox.hs +++ b/src/Client/State/EditBox.hs @@ -64,6 +64,9 @@ 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) data EditBox = EditBox @@ -273,7 +276,7 @@ . set lastOperation OtherOperation -insertDigraph :: EditBox -> Maybe EditBox -insertDigraph - = content digraph +insertDigraph :: Map Digraph Text -> EditBox -> Maybe EditBox +insertDigraph extras + = content (digraph extras) . set lastOperation OtherOperation 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,12 +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 Digraphs (lookupDigraph) +import Data.Map (Map) +import qualified Data.Map as Map +import Data.Text (Text) +import qualified Data.Text as Text +import Digraphs (Digraph(..), lookupDigraph) data Line = Line { _pos :: !Int @@ -279,13 +284,15 @@ -- | Use the two characters preceeding the cursor as a digraph and replace -- them with the corresponding character. -digraph :: Content -> Maybe Content -digraph !c = +digraph :: Map Digraph Text -> Content -> Maybe Content +digraph extras !c = do let Line n txt = view line c guard (2 <= n) let (pfx,x:y:sfx) = splitAt (n - 2) txt - d <- lookupDigraph x y - let line' = Line (n-1) (pfx++d:sfx) + let key = Digraph x y + d <- Text.unpack <$> Map.lookup key extras + <|> pure <$> lookupDigraph key + let line' = Line (n-1) (pfx++d++sfx) Just $! set line line' c fromStrings :: NonEmpty String -> Content 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 @@ -81,6 +81,8 @@ ) 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 @@ -113,6 +115,7 @@ import Irc.UserInfo import LensUtils import qualified System.Random as Random +import qualified Data.ByteString.Base64 as B64 -- | State tracked for each IRC connection data NetworkState = NetworkState @@ -152,7 +155,11 @@ | AS_EcdsaStarted -- ^ ECDSA-NIST mode initiated | AS_EcdsaWaitChallenge -- ^ ECDSA-NIST user sent waiting for challenge | AS_ExternalStarted -- ^ EXTERNAL mode initiated - deriving Show + | AS_ScramStarted + | AS_Scram1 Scram.Phase1 + | AS_Scram2 Scram.Phase2 + | AS_EcdhStarted + | AS_EcdhWaitChallenge Ecdh.Phase1 -- | Status of the ping timer data PingStatus @@ -330,43 +337,42 @@ Pong _ -> noReply (doPong msgWhen cs) Join user chan acct _ -> reply response - $ recordUser user acct - $ overChannel chan (joinChannel (userNick user)) - $ createOnJoin user chan cs + $ recordUser (srcUser user) acct + $ overChannel chan (joinChannel (userNick (srcUser user))) + $ createOnJoin (srcUser user) chan cs where - showAccounts = view (csSettings . ssShowAccounts) cs - response - | userNick user == view csNick cs = - ircMode chan [] : - [ircWho [idText chan, "%tuhna,616"] | showAccounts ] - | otherwise = [] + response = + [ircMode chan [] | userNick (srcUser user) == view csNick cs] Account user acct -> noReply - $ recordUser user acct cs + $ recordUser (srcUser user) acct cs Chghost user newUser newHost -> noReply - $ updateUserInfo (userNick user) newUser newHost cs + $ updateUserInfo (userNick (srcUser user)) newUser newHost cs Quit user _reason -> noReply - $ forgetUser (userNick user) - $ overChannels (partChannel (userNick user)) cs + $ forgetUser (userNick (srcUser user)) + $ overChannels (partChannel (userNick (srcUser user))) cs - Part user chan _mbreason -> exitChannel chan (userNick user) + Part user chan _mbreason -> exitChannel chan (userNick (srcUser user)) Kick _kicker chan nick _reason -> exitChannel chan nick Nick oldNick newNick -> + let nick = userNick (srcUser oldNick) in noReply - $ renameUser (userNick oldNick) newNick - $ updateMyNick (userNick oldNick) newNick - $ overChannels (nickChange (userNick oldNick) newNick) cs + $ renameUser nick newNick + $ updateMyNick nick newNick + $ overChannels (nickChange nick newNick) cs Reply _ RPL_WELCOME (me:_) -> doWelcome msgWhen (mkId me) cs Reply _ RPL_SASLSUCCESS _ -> reply [ircCapEnd] cs - Reply _ RPL_SASLFAIL _ -> reply [ircCapEnd] cs + Reply _ ERR_SASLFAIL _ -> reply [ircCapEnd] cs + Reply _ ERR_SASLABORTED _ -> reply [ircCapEnd] cs + Reply _ RPL_SASLMECHS _ -> reply [ircCapEnd] cs Reply _ ERR_NICKNAMEINUSE (_:badnick:_) | PingConnecting{} <- view csPingStatus cs -> doBadNick badnick cs @@ -388,8 +394,8 @@ Reply _ code args -> doRpl code msgWhen args cs Cap cmd -> doCap cmd cs Authenticate param -> doAuthenticate param cs - Mode who target (modes:params) -> doMode msgWhen who target modes params cs - Topic user chan topic -> noReply (doTopic msgWhen user chan topic cs) + Mode who target (modes:params) -> doMode msgWhen (srcUser who) target modes params cs + Topic user chan topic -> noReply (doTopic msgWhen (srcUser user) chan topic cs) _ -> noReply cs where exitChannel chan nick @@ -761,7 +767,8 @@ sasl ++ serverTime ++ ["multi-prefix", "batch", "znc.in/playback", "znc.in/self-message" , "cap-notify", "extended-join", "account-notify", "chghost" - , "userhost-in-names", "account-tag" ] + , "userhost-in-names", "account-tag", "solanum.chat/identify-msg" + , "solanum.chat/realhost" ] -- logic for using IRCv3.2 server-time if available and falling back -- to ZNC's specific extension otherwise. @@ -773,11 +780,27 @@ ss = view csSettings cs sasl = ["sasl" | isJust (view ssSaslMechanism ss) ] +decodeAuthParam :: Text -> Maybe B.ByteString +decodeAuthParam "+" = Just "" +decodeAuthParam xs = + case B64.decode (Text.encodeUtf8 xs) of + Right bs -> Just bs + Left _ -> Nothing + +abortAuth :: NetworkState -> Apply +abortAuth = reply [ircAuthenticate "*"] . set csAuthenticationState AS_None + doAuthenticate :: Text -> NetworkState -> Apply -doAuthenticate param cs = +doAuthenticate paramTxt cs = + case decodeAuthParam paramTxt of + Nothing -> abortAuth cs + Just param -> doAuthenticate' param cs + +doAuthenticate' :: B.ByteString -> NetworkState -> Apply +doAuthenticate' param cs = case view csAuthenticationState cs of AS_PlainStarted - | "+" <- param + | B.null param , Just (SaslPlain mbAuthz authc (SecretText pass)) <- view ssSaslMechanism ss , let authz = fromMaybe "" mbAuthz -> reply @@ -785,7 +808,7 @@ (set csAuthenticationState AS_None cs) AS_ExternalStarted - | "+" <- param + | B.null param , Just (SaslExternal mbAuthz) <- view ssSaslMechanism ss , let authz = fromMaybe "" mbAuthz -> reply @@ -793,21 +816,73 @@ (set csAuthenticationState AS_None cs) AS_EcdsaStarted - | "+" <- param + | B.null param , Just (SaslEcdsa mbAuthz authc _) <- view ssSaslMechanism ss - , let authz = fromMaybe authc mbAuthz -> reply - (ircAuthenticates (Ecdsa.encodeAuthentication authz authc)) + (ircAuthenticates (Ecdsa.encodeAuthentication mbAuthz authc)) (set csAuthenticationState AS_EcdsaWaitChallenge cs) AS_EcdsaWaitChallenge -> noReply cs -- handled in Client.EventLoop! - _ -> reply [ircCapEnd] cs -- really shouldn't happen + AS_ScramStarted + | B.null param + , Just (SaslScram digest mbAuthz user (SecretText pass)) + <- view ssSaslMechanism ss + , let authz = fromMaybe "" mbAuthz + , (nonce, cs') <- cs & csSeed %%~ scramNonce + , (msg, scram1) <- + Scram.initiateScram digest + (Text.encodeUtf8 user) + (Text.encodeUtf8 authz) + (Text.encodeUtf8 pass) + nonce + -> reply + (ircAuthenticates msg) + (set csAuthenticationState (AS_Scram1 scram1) cs') + AS_Scram1 scram1 + | Just (rsp, scram2) <- Scram.addServerFirst scram1 param + -> reply + (ircAuthenticates rsp) + (set csAuthenticationState (AS_Scram2 scram2) cs) + + AS_Scram2 scram2 + | Scram.addServerFinal scram2 param + -> reply + [ircAuthenticate "+"] + (set csAuthenticationState AS_None cs) + + AS_EcdhStarted + | B.null param + , Just (SaslEcdh mbAuthz authc (SecretText key)) <- view ssSaslMechanism ss + , Just (rsp, ecdh1) <- Ecdh.clientFirst mbAuthz authc key + -> reply + (ircAuthenticates rsp) + (set csAuthenticationState (AS_EcdhWaitChallenge ecdh1) cs) + + AS_EcdhWaitChallenge ecdh1 + | Just rsp <- Ecdh.clientResponse ecdh1 param + -> reply (ircAuthenticates rsp) (set csAuthenticationState AS_None cs) + + _ -> abortAuth cs + where ss = view csSettings cs +scramNonce :: Random.StdGen -> (B.ByteString, Random.StdGen) +scramNonce = go [] nonceSize + where + alphabet = "!\"#$%&'()*+-./0123456789:;<=>?@\ + \ABCDEFGHIJKLMNOPQRSTUVWXYZ[\\]^_`\ + \abcdefghijklmnopqrstuvwxyz{|}~" + nonceSize = 20 :: Int -- ceiling (128 / logBase 9 (length alphabet)) + + go acc 0 g = (B.pack acc, g) + go acc i g = + case Random.randomR (0, B.length alphabet-1) g of + (x,g') -> go (B.index alphabet x:acc) (i-1) g' + doCap :: CapCmd -> NetworkState -> Apply doCap cmd cs = case cmd of @@ -845,6 +920,12 @@ SaslExternal{} -> reply [ircAuthenticate "EXTERNAL"] (set csAuthenticationState AS_ExternalStarted cs) + SaslScram digest _ _ _ -> + reply [ircAuthenticate (Scram.mechanismName digest)] + (set csAuthenticationState AS_ScramStarted cs) + SaslEcdh{} -> + reply [ircAuthenticate Ecdh.mechanismName] + (set csAuthenticationState AS_EcdhStarted cs) _ -> reply [ircCapEnd] cs diff --git a/src/Client/View/Cert.hs b/src/Client/View/Cert.hs --- a/src/Client/View/Cert.hs +++ b/src/Client/View/Cert.hs @@ -30,7 +30,7 @@ , Just cs <- preview (clientConnection network) st , let xs = view csCertificate cs , not (null xs) - = map parseIrcText + = map (parseIrcText pal) $ clientFilter st LText.fromStrict xs | otherwise = [text' (view palError pal) "No certificate available"] diff --git a/src/Client/View/ChannelInfo.hs b/src/Client/View/ChannelInfo.hs --- a/src/Client/View/ChannelInfo.hs +++ b/src/Client/View/ChannelInfo.hs @@ -62,7 +62,7 @@ label = text' (view palLabel pal) topicLine = label "Topic: " <> - parseIrcText (view chanTopic channel) + parseIrcText pal (view chanTopic channel) utcTimeImage = string defAttr . formatTime defaultTimeLocale "%F %T" @@ -84,14 +84,14 @@ urlLines = case view chanUrl channel of Nothing -> [] - Just url -> [ label "Channel URL: " <> parseIrcText url ] + Just url -> [ label "Channel URL: " <> parseIrcText pal url ] modeLines = [label "Modes: " <> string defAttr modes | not (null modes) ] where modes = views chanModes Map.keys channel modeArgLines = - [ string (view palLabel pal) ("Mode " ++ [mode, ':', ' ']) <> parseIrcText arg + [ string (view palLabel pal) ("Mode " ++ [mode, ':', ' ']) <> parseIrcText pal arg | (mode, arg) <- Map.toList (view chanModes channel) , not (Text.null arg) ] diff --git a/src/Client/View/Help.hs b/src/Client/View/Help.hs --- a/src/Client/View/Help.hs +++ b/src/Client/View/Help.hs @@ -1,4 +1,4 @@ -{-# Language BangPatterns, OverloadedStrings #-} +{-# Language BangPatterns, OverloadedStrings, TransformListComp #-} {-| Module : Client.View.Help @@ -14,8 +14,10 @@ ( helpImageLines ) where -import Client.State (ClientState) +import Client.State (ClientState, clientConfig) +import Client.Configuration (configMacros) import Client.Commands +import Client.Commands.Interpolation import Client.Commands.Arguments.Spec import Client.Commands.Arguments.Renderer import Client.Commands.Recognizer @@ -24,7 +26,7 @@ import Client.Image.Palette import Control.Lens import Data.Foldable (toList) -import Data.List (delete, intercalate) +import Data.List (delete, intercalate, sortOn) import Data.List.NonEmpty (NonEmpty((:|))) import Data.Text (Text) import qualified Data.Text as Text @@ -63,7 +65,7 @@ : aliasLines ++ explainContext impl : emptyLine - : map parseIrcText (Text.lines doc) + : map (parseIrcText pal) (Text.lines doc) where aliasLines = case delete cmdName (toList names) of @@ -97,7 +99,23 @@ listAllCommands st pal = intercalate [emptyLine] $ map reverse - $ listCommandSection st pal <$> commandsList + $ (listCommandSection st pal <$> commandsList) + ++ [macroCommandSection st pal] + +macroCommandSection :: + ClientState {- ^ client state -} -> + Palette {- ^ palette -} -> + [Image'] {- ^ help lines -} +macroCommandSection st pal + | null macros = [] + | otherwise = + text' (withStyle defAttr bold) "Macros" : + [ commandSummary st pal (pure name) spec + | Macro name (MacroSpec spec) _ <- macros + , then sortOn by name + ] + where + macros = toListOf (clientConfig . configMacros . folded) st listCommandSection :: ClientState {- ^ client state -} -> 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,6 +28,7 @@ import Control.Lens import Control.Monad import Data.List +import Graphics.Vty.Attributes import Irc.Identifier import Irc.Message import Irc.UserInfo @@ -141,8 +142,11 @@ continueMetadata :: Image' -> MetadataState continueMetadata acc _ [] _ = [acc] continueMetadata acc who1 ((img, who2, mbwho3):mds) palette - | who1 == who2 = let acc' = acc <> img - in transitionMetadata acc' mbwho3 who2 mds palette + | who1 /= "" -- empty identifiers don't coallese + , who1 == who2 + , let acc' = acc <> img + = transitionMetadata acc' mbwho3 who2 mds palette + | otherwise = acc : startMetadata img mbwho3 who2 mds palette ------------------------------------------------------------------------ @@ -154,6 +158,9 @@ -- ^ metadata entries are reversed gatherMetadataLines st = go [] where + go acc ws + | Just (img, ws') <- bulkMetadata st ws = + go ((img, "", Nothing) : acc) ws' go acc (w:ws) | Just (img,who,mbnext) <- metadataWindowLine st w = go ((img,who,mbnext) : acc) ws @@ -170,5 +177,24 @@ metadataWindowLine st wl = case view wlSummary wl of ChatSummary who -> (ignoreImage, userNick who, Nothing) <$ guard (identIgnored who st) - DccSendSummary _ -> Nothing -- Show a custom WindowLine latter summary -> metadataImg summary + +bulkMetadata :: + ClientState -> + [WindowLine] -> + Maybe (Image', [WindowLine]) +bulkMetadata st wls + | (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') + where + pal = clientPalette st + +bulkMetadata _ _ = Nothing + +isMassQuit :: WindowLine -> Bool +isMassQuit wl + | QuitSummary _ MassQuit <- view wlSummary wl = True + | otherwise = False diff --git a/src/Client/View/Palette.hs b/src/Client/View/Palette.hs --- a/src/Client/View/Palette.hs +++ b/src/Client/View/Palette.hs @@ -48,8 +48,8 @@ [ "" , "Chat formatting modes:" , "" - , " C-b C-_ C-] C-v C-^ C-o" - , parseIrcText " \^Bbold\^B \^_underline\^_ \^]italic\^] \^Vreverse\^V \^^strikethrough\^^ reset" + , " C-b C-_ C-] C-v C-^ C-q C-o" + , parseIrcText pal " \^Bbold\^B \^_underline\^_ \^]italic\^] \^Vreverse\^V \^^strikethrough\^^ \^Qmonospace\^Q reset" , "" , "Chat formatting colors: C-c[foreground[,background]]" , "" @@ -63,7 +63,7 @@ terminalColorTable :: [Image'] terminalColorTable = - isoColors : + isoColors ++ "" : colorBox 0x10 ++ "" : colorBox 0x7c ++ "" : indent (foldMap (\c -> colorBlock showPadHex c (Color240 (fromIntegral (c-16)))) [0xe8 .. 0xf3]) @@ -89,8 +89,11 @@ Nothing -> True -isoColors :: Image' -isoColors = indent (foldMap (\c -> colorBlock showPadHex c (ISOColor (fromIntegral c))) [0 .. 15]) +isoColors :: [Image'] +isoColors = + [ indent (foldMap (\c -> colorBlock showPadHex c (ISOColor (fromIntegral c))) [0 .. 7]) + , indent (foldMap (\c -> colorBlock showPadHex c (ISOColor (fromIntegral c))) [8 .. 15]) + ] colorTable :: [Image'] colorTable 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 @@ -28,7 +28,6 @@ import Data.Text (Text) import Graphics.Vty.Attributes import Irc.Identifier -import Irc.UserInfo (userNick) import Text.Read (readMaybe) @@ -64,21 +63,6 @@ matches :: WindowLine -> [(Maybe Identifier, Text)] matches wl = [ (views wlSummary summaryActor wl, url) | url <- views wlText urlMatches wl ] - -summaryActor :: IrcSummary -> Maybe Identifier -summaryActor s = - case s of - JoinSummary who -> Just who - QuitSummary who -> Just who - PartSummary who -> Just who - NickSummary who _ -> Just who - ChatSummary who -> Just (userNick who) - CtcpSummary who -> Just who - DccSendSummary who -> Just who - AcctSummary who -> Just who - ChngSummary who -> Just who - ReplySummary {} -> Nothing - NoSummary -> Nothing -- | Render one line of the url list diff --git a/src/Digraphs.hs b/src/Digraphs.hs --- a/src/Digraphs.hs +++ b/src/Digraphs.hs @@ -14,7 +14,8 @@ -} module Digraphs - ( lookupDigraph + ( Digraph(..) + , lookupDigraph , digraphs ) where @@ -22,6 +23,10 @@ import Data.Text (Text) import qualified Data.Text as Text +-- | Two-character key for digraph lookup +data Digraph = Digraph !Char !Char + deriving (Eq, Ord, Read, Show) + -- | States for the digraph lookup state machine data St = Ready -- ^ ready to match two-character name @@ -32,8 +37,8 @@ -- | Find the entry in the digraph table give a two-character -- key and return the matched value. -lookupDigraph :: Char -> Char -> Maybe Char -lookupDigraph !x !y = Text.foldr step finish digraphs Ready +lookupDigraph :: Digraph -> Maybe Char +lookupDigraph (Digraph x y) = Text.foldr step finish digraphs Ready where finish _st = Nothing step z k st =