glirc 2.38 → 2.39
raw patch · 50 files changed
+1499/−644 lines, 50 filesdep +curve25519dep +githashdep −gitrevdep ~attoparsecdep ~basedep ~config-schema
Dependencies added: curve25519, githash
Dependencies removed: gitrev
Dependency ranges changed: attoparsec, base, config-schema, hashable, hookup, lens, template-haskell, text, time, transformers, vty
Files
- ChangeLog.md +11/−2
- README.md +5/−12
- glirc.1 +2/−2
- glirc.cabal +132/−124
- src/Client/Authentication/Ecdh.hs +61/−0
- src/Client/Authentication/Ecdsa.hs +6/−5
- src/Client/Authentication/Scram.hs +184/−0
- src/Client/CApi/Exports.hs +2/−2
- src/Client/Commands.hs +2/−2
- src/Client/Commands/Arguments/Renderer.hs +1/−1
- src/Client/Commands/Certificate.hs +1/−1
- src/Client/Commands/Chat.hs +77/−44
- src/Client/Commands/Interpolation.hs +2/−1
- src/Client/Commands/Operator.hs +165/−5
- src/Client/Commands/Queries.hs +16/−7
- src/Client/Commands/Recognizer.hs +2/−2
- src/Client/Commands/TabCompletion.hs +4/−4
- src/Client/Commands/Toggles.hs +10/−1
- src/Client/Configuration.hs +19/−0
- src/Client/Configuration/Macros.hs +1/−1
- src/Client/Configuration/ServerSettings.hs +60/−12
- src/Client/EventLoop.hs +13/−7
- src/Client/EventLoop/Actions.hs +3/−0
- src/Client/Hook.hs +1/−0
- src/Client/Hook/DroneBLRelay.hs +216/−0
- src/Client/Hook/FreRelay.hs +0/−216
- src/Client/Hook/Matterbridge.hs +69/−0
- src/Client/Hook/Snotice.hs +11/−11
- src/Client/Hook/Znc/Buffextras.hs +10/−9
- src/Client/Hooks.hs +5/−3
- src/Client/Image/Message.hs +111/−44
- src/Client/Image/MircFormatting.hs +18/−10
- src/Client/Image/Palette.hs +4/−0
- src/Client/Image/StatusLine.hs +10/−0
- src/Client/Image/Textbox.hs +2/−2
- src/Client/Log.hs +3/−3
- src/Client/Message.hs +42/−13
- src/Client/Network/Connect.hs +2/−1
- src/Client/Options.hs +7/−18
- src/Client/State.hs +9/−6
- src/Client/State/EditBox.hs +6/−3
- src/Client/State/EditBox/Content.hs +12/−5
- src/Client/State/Network.hs +110/−29
- src/Client/View/Cert.hs +1/−1
- src/Client/View/ChannelInfo.hs +3/−3
- src/Client/View/Help.hs +23/−5
- src/Client/View/Messages.hs +29/−3
- src/Client/View/Palette.hs +8/−5
- src/Client/View/UrlSelection.hs +0/−16
- src/Digraphs.hs +8/−3
ChangeLog.md view
@@ -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
README.md view
@@ -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 <extension name> <params...>` - Send the given params to the named extension * `/exec [-n network] [-c channel] <command> <arguments...>` - 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 =====
glirc.1 view
@@ -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"
glirc.cabal view
@@ -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
+ src/Client/Authentication/Ecdh.hs view
@@ -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")
src/Client/Authentication/Ecdsa.hs view
@@ -7,8 +7,7 @@ Maintainer : emertens@gmail.com Implementation of ECDSA-NIST256P-CHALLENGE SASL authentication mode-as implemented at <https://github.com/kaniini/ecdsatool> and used-on Freenode.+as implemented at <https://github.com/kaniini/ecdsatool>. 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@
+ src/Client/Authentication/Scram.hs view
@@ -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
src/Client/CApi/Exports.hs view
@@ -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 }
src/Client/Commands.hs view
@@ -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 =
src/Client/Commands/Arguments/Renderer.hs view
@@ -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
src/Client/Commands/Certificate.hs view
@@ -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\
src/Client/Commands/Chat.hs view
@@ -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
src/Client/Commands/Interpolation.hs view
@@ -51,7 +51,8 @@ data Macro = Macro- { macroSpec :: MacroSpec+ { macroName :: Text+ , macroSpec :: MacroSpec , macroCommands :: [[ExpansionChunk]] } deriving Show
src/Client/Commands/Operator.hs view
@@ -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)
src/Client/Commands/Queries.hs view
@@ -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)
src/Client/Commands/Recognizer.hs view
@@ -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
src/Client/Commands/TabCompletion.hs view
@@ -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
src/Client/Commands/Toggles.hs view
@@ -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)
src/Client/Configuration.hs view
@@ -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 -} ->
src/Client/Configuration/Macros.hs view
@@ -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
src/Client/Configuration/ServerSettings.hs view
@@ -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
src/Client/EventLoop.hs view
@@ -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
src/Client/EventLoop/Actions.hs view
@@ -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") ]) :
src/Client/Hook.hs view
@@ -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
+ src/Client/Hook/DroneBLRelay.hs view
@@ -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
− src/Client/Hook/FreRelay.hs
@@ -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
+ src/Client/Hook/Matterbridge.hs view
@@ -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) ""
src/Client/Hook/Snotice.hs view
@@ -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 |]),
src/Client/Hook/Znc/Buffextras.hs view
@@ -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]
src/Client/Hooks.hs view
@@ -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) ]
src/Client/Image/Message.hs view
@@ -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 == "<NULL>" 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 == "<NULL>" 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'
src/Client/Image/MircFormatting.hs view
@@ -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) ->
src/Client/Image/Palette.hs view
@@ -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) ]
src/Client/Image/StatusLine.hs view
@@ -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
src/Client/Image/Textbox.hs view
@@ -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
src/Client/Log.hs view
@@ -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
src/Client/Message.hs view
@@ -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+
src/Client/Network/Connect.hs view
@@ -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)
src/Client/Options.hs view
@@ -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 = ""
src/Client/State.hs view
@@ -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
src/Client/State/EditBox.hs view
@@ -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
src/Client/State/EditBox/Content.hs view
@@ -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
src/Client/State/Network.hs view
@@ -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
src/Client/View/Cert.hs view
@@ -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"]
src/Client/View/ChannelInfo.hs view
@@ -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) ]
src/Client/View/Help.hs view
@@ -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 -} ->
src/Client/View/Messages.hs view
@@ -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
src/Client/View/Palette.hs view
@@ -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
src/Client/View/UrlSelection.hs view
@@ -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
src/Digraphs.hs view
@@ -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 =