diff --git a/ChangeLog.md b/ChangeLog.md --- a/ChangeLog.md +++ b/ChangeLog.md @@ -1,4 +1,40 @@ -# Revision history for glirc2 +# Revision history for glirc + +## 2.36 + +* **Changed executable name to `glirc`** +* Allow all windows (not just chat message windows) to be added as split-screen targets +* Chose a random nickname when list of alternatives is exhausted +* Add simple man page +* Add `/monitor` +* Support specifying `bind-hostname` to pick a local address to connect + from in favor of `protocol-family`. To pick a protocol family you + can now specify `bind-hostname: "0.0.0.0"` or `bind-hostname: "::"` +* Add TLS key PEM password configuration +* Make all configuration file passwords able to be loaded from executing a command +* Make SASL mechanism specification specific and support an optional + authorization identity `authzid` used in rare circumstances but + supported by SASL. + + ``` + sasl: -- example 1 + mechanism: plain -- sasl defaults to plain if not specified + username: "myuser" + password: "mypassword" + + sasl: -- example 2 + mechanism: external + authzid: "otheruser" -- optional + + sasl: -- example 3 + mechanism: ecdsa-nist256p-challenge + username: "myuser" + private-key: "path/to/my.key" + ``` + + Note that now using a client-side TLS certificate is an independent + configuration from using EXTERNAL. To use both you need to configure + both! ## 2.35 * Added client certificate information to `/cert` diff --git a/README.md b/README.md --- a/README.md +++ b/README.md @@ -87,7 +87,7 @@ -- vim: filetype=config-value -- Grab the Vim syntax highlighting file from the config-value package --- Learn more about these settings with `glirc2 --config-format` +-- Learn more about these settings with `glirc --config-format` -- Defaults used when not specified on command line defaults: diff --git a/exec/Exports.hs b/exec/Exports.hs --- a/exec/Exports.hs +++ b/exec/Exports.hs @@ -5,7 +5,7 @@ License : ISC Maintainer : emertens@gmail.com -Entry point into glirc2 from the C API +Entry point into glirc from the C API -} module Exports () where diff --git a/exec/Main.hs b/exec/Main.hs --- a/exec/Main.hs +++ b/exec/Main.hs @@ -5,7 +5,7 @@ License : ISC Maintainer : emertens@gmail.com -Entry point into glirc2. This module sets up VTY and launches the client. +Entry point into glirc. This module sets up VTY and launches the client. -} module Main where diff --git a/glirc.1 b/glirc.1 new file mode 100644 --- /dev/null +++ b/glirc.1 @@ -0,0 +1,64 @@ +.TH GLIRC 1 2020-07-27 "Glirc IRC client" +.SH NAME +Glirc \- an IRC client +.SH SYNOPSIS +.B glirc +[\-\-config=PATH] [\-\-noconnect] [\-\-version] [\-\-full\-version] +[\-\-config-format] [\-\-help] [network...] +.SH DESCRIPTION +.B Glirc +is a fully-featured console IRC client. It focuses on providing both +high-detail and concise views of an IRC connection. It provides an +advanced line-editing environment including syntax-highlighting, +multi-line buffering, and argument placeholders. +.SH OPTIONS +.TP +.BI "\-c, \-\-config="PATH +use +.I PATH +instead of ~/.config/glirc/config +.TP +.BI "\-!, \-\-noconnect" +disable autoconnecting +.TP +.BI "\-v, \-\-version" +print version information +.TP +.BI "\-\-full\-version" +show detailed version information +.TP +.BI "\-\-config\-format" +show configuration file format +.TP +.BI "\-h, \-\-help" +show help message +.TP +.I network +networks to connect to on startup +.SH NOTES +.B Glirc +has online documentation available inside with /help and online at +https://github.com/glguy/irc-core/wiki +.SH FILES +.TP +.I ~/.config/glirc/config +configuration file +.TP +.I ~/.config/glirc/sts.cfg +Strict Transport Security state +.SH EXAMPLES +Sample simple configuration file. More detail available at +https://github.com/glguy/irc-core/wiki/Configuration-File + +.RS +defaults: + nick: "glircuser" + tls: yes + +servers: + * name: "freenode" + hostname: "chat.freenode.net" + + * name: "oftc" + hostname: "irc.oftc.net" +.RE diff --git a/glirc.cabal b/glirc.cabal --- a/glirc.cabal +++ b/glirc.cabal @@ -1,6 +1,6 @@ cabal-version: 2.2 name: glirc -version: 2.35 +version: 2.36 synopsis: Console IRC client description: Console IRC client . @@ -17,12 +17,13 @@ extra-source-files: ChangeLog.md README.md exec/linux_exported_symbols.txt exec/macos_exported_symbols.txt +extra-doc-files: glirc.1 homepage: https://github.com/glguy/irc-core bug-reports: https://github.com/glguy/irc-core/issues tested-with: GHC==8.6.5 custom-setup - setup-depends: base >=4.12 && <4.14, + setup-depends: base >=4.12 && <4.15, filepath >=1.4 && <1.5, Cabal >=2.2 && <4 @@ -31,7 +32,7 @@ location: git://github.com/glguy/irc-core.git branch: v2 -executable glirc2 +executable glirc main-is: Main.hs other-modules: Exports ghc-options: -threaded -rtsopts @@ -61,13 +62,24 @@ Client.CApi.Exports Client.CApi.Types Client.Commands - Client.Commands.Arguments.Spec Client.Commands.Arguments.Parser Client.Commands.Arguments.Renderer + Client.Commands.Arguments.Spec + Client.Commands.Channel + Client.Commands.Chat + Client.Commands.Connection + Client.Commands.DCC 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 @@ -137,11 +149,11 @@ autogen-modules: Paths_glirc Build_glirc - build-depends: base >=4.11 && <4.14, + build-depends: base >=4.11 && <4.15, HsOpenSSL >=0.11 && <0.12, async >=2.2 && <2.3, attoparsec >=0.13 && <0.14, - base64-bytestring >=1.0.0.1&& <1.1, + base64-bytestring >=1.0.0.1&& <1.2, bytestring >=0.10.8 && <0.11, config-schema ^>=1.2.0.0, config-value ^>=0.7, @@ -151,10 +163,11 @@ free >=4.12 && <5.2, gitrev >=1.2 && <1.4, hashable >=1.2.4 && <1.4, - hookup >=0.3.1 && <0.4, - irc-core >=2.7.1 && <2.8, + hookup >=0.4 && <0.5, + irc-core >=2.8 && <2.9, kan-extensions >=5.0 && <5.3, lens >=4.14 && <4.20, + mwc-random >=0.14 && <0.15, network >=2.6.2 && <3.2, process >=1.4.2 && <1.7, psqueues >=0.2.7 && <0.3, @@ -162,14 +175,14 @@ semigroupoids >=5.1 && <5.4, split >=0.2 && <0.3, stm >=2.4 && <2.6, - template-haskell >=2.11 && <2.16, + template-haskell >=2.11 && <2.17, text >=1.2.2 && <1.3, - time >=1.6 && <1.10, + time >=1.6 && <1.11, 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.23.1 && <5.28 + vty >=5.23.1 && <5.31 test-suite test type: exitcode-stdio-1.0 diff --git a/src/Client/Authentication/Ecdsa.hs b/src/Client/Authentication/Ecdsa.hs --- a/src/Client/Authentication/Ecdsa.hs +++ b/src/Client/Authentication/Ecdsa.hs @@ -16,7 +16,7 @@ -} module Client.Authentication.Ecdsa ( authenticationMode - , encodeUsername + , encodeAuthentication , computeResponse ) where @@ -37,10 +37,12 @@ -- | Encode a username as specified in this authentication mode. -encodeUsername :: - Text {- ^ username -} -> - AuthenticatePayload {- ^ base-64 encoded username -} -encodeUsername = AuthenticatePayload . Text.encodeUtf8 +encodeAuthentication :: + Text {- ^ authorization identity -} -> + Text {- ^ authentication identity -} -> + AuthenticatePayload +encodeAuthentication authz authc = + AuthenticatePayload (Text.encodeUtf8 (authz <> "\0" <> authc <> "\0")) -- | Compute the response for a given challenge using the @ecdsatool@ diff --git a/src/Client/Commands.hs b/src/Client/Commands.hs --- a/src/Client/Commands.hs +++ b/src/Client/Commands.hs @@ -32,2475 +32,500 @@ import Client.Commands.Recognizer import Client.Commands.WordCompletion import Client.Configuration -import Client.Mask -import Client.Message -import Client.Image.PackedImage (imageText) -import Client.State -import Client.State.Channel -import Client.State.DCC -import qualified Client.State.EditBox as Edit -import Client.State.Extensions -import Client.State.Focus -import Client.State.Network -import Client.State.Window -import Client.UserHost -import Control.Applicative -import Control.Concurrent.Async (cancel) -import Control.Exception (displayException, try, SomeException) -import Control.Lens -import Control.Monad -import Data.Foldable -import Data.HashSet (HashSet) -import Data.List (nub, (\\)) -import Data.List.NonEmpty (NonEmpty((:|))) -import Data.List.Split -import qualified Data.HashMap.Strict as HashMap -import qualified Data.Map as Map -import Data.Maybe (fromMaybe) -import Data.Text (Text) -import qualified Data.Text as Text -import qualified Data.Text.Lazy as LText -import qualified Data.Text.Lazy.IO as LText -import Data.Time -import Irc.Commands -import Irc.Identifier -import Irc.RawIrcMsg -import Irc.Message -import Irc.UserInfo -import Irc.Modes -import LensUtils -import RtsStats (getStats) -import System.Directory (doesDirectoryExist) -import System.FilePath (()) -import System.Process - --- | Possible results of running a command -data CommandResult - -- | Continue running the client, consume input if command was from input - = CommandSuccess ClientState - -- | Continue running the client, report an error - | CommandFailure ClientState - -- | Client should close - | CommandQuit ClientState - - --- | Type of commands that always work -type ClientCommand a = ClientState -> a {- ^ arguments -} -> IO CommandResult - --- | Type of commands that require an active network to be focused -type NetworkCommand a = NetworkState {- ^ current network -} -> ClientCommand a - --- | Type of commands that require an active channel to be focused -type ChannelCommand a = Identifier {- ^ focused channel -} -> NetworkCommand a - - --- | Pair of implementations for executing a command and tab completing one. --- The tab-completion logic is extended with a Bool --- indicating that tab completion should be reversed -data CommandImpl a - -- | no requirements - = ClientCommand (ClientCommand a) (Bool -> ClientCommand String) - -- | requires an active network - | NetworkCommand (NetworkCommand a) (Bool -> NetworkCommand String) - -- | requires an active chat window - | ChatCommand (ChannelCommand a) (Bool -> ChannelCommand String) - -- | requires an active channel window - | ChannelCommand (ChannelCommand a) (Bool -> ChannelCommand String) - - --- | A command is a list of aliases, an argument specification, implementation, --- and documentation. The arguments and implementation must match so that --- the parsed arguments will match what the implementation expects. -data Command = forall a. Command - { -- | Names of this command, first in the list is the "primary" name - cmdNames :: NonEmpty Text - -- | Specification of the arguments of the command - , cmdArgumentSpec :: Args ClientState a - -- | Multi-line IRC-formatted documentation text used for @/help@ - , cmdDocumentation :: Text - -- | Implementation of the command for both execution and tab completion - , cmdImplementation :: CommandImpl a - } - --- | A command section is a logical grouping of commands. This allows for --- showing more structure in the help menu system. -data CommandSection = CommandSection - { cmdSectionName :: Text - , cmdSectionCmds :: [Command] - } - --- | Consider the text entry successful and resume the client -commandSuccess :: Monad m => ClientState -> m CommandResult -commandSuccess = return . CommandSuccess - --- | Consider the text entry a failure and resume the client -commandFailure :: Monad m => ClientState -> m CommandResult -commandFailure = return . CommandFailure - --- | Command failure with an error message printed to client window -commandFailureMsg :: Text -> ClientState -> IO CommandResult -commandFailureMsg e st = - return $! CommandFailure $! set clientErrorMsg (Just e) st - --- | Interpret the given chat message or command. Leading @/@ indicates a --- command. Otherwise if a channel or user query is focused a chat message will --- be sent. Leading spaces before the @/@ are ignored when checking for --- commands. -execute :: - String {- ^ chat or command -} -> - ClientState {- ^ client state -} -> - IO CommandResult {- ^ command result -} -execute str st = - let st' = set clientErrorMsg Nothing st in - case dropWhile (' '==) str of - [] -> commandFailure st - '/':command -> executeUserCommand Nothing command st' - _ -> executeChat str st' - --- | Execute command provided by user, resolve aliases if necessary. --- --- The last disconnection time is stored in text form and is available --- for substitutions in macros. It is only provided when running startup --- commands during a reconnect event. -executeUserCommand :: - Maybe Text {- ^ disconnection time -} -> - String {- ^ command -} -> - ClientState {- ^ client state -} -> - IO CommandResult {- ^ command result -} -executeUserCommand discoTime command st = do - let key = Text.takeWhile (/=' ') (Text.pack command) - rest = dropWhile (==' ') (dropWhile (/=' ') command) - - case views (clientConfig . configMacros) (recognize key) st of - Exact (Macro (MacroSpec spec) cmdExs) -> - case doExpansion spec cmdExs rest of - Nothing -> commandFailureMsg "macro expansions failed" st - Just cmds -> process cmds st - _ -> executeCommand Nothing command st - where - doExpansion spec cmdExs rest = - do args <- parse st spec rest - traverse (resolveMacro (map Text.pack args)) cmdExs - - resolveMacro args = resolveMacroExpansions (commandExpansion discoTime st) (expandInt args) - - expandInt :: [a] -> Integer -> Maybe a - expandInt args i = preview (ix (fromInteger i)) args - - - - process [] st0 = commandSuccess st0 - process (c:cs) st0 = - do res <- executeCommand Nothing (Text.unpack c) st0 - case res of - CommandSuccess st1 -> process cs st1 - CommandFailure st1 -> process cs st1 -- ? - CommandQuit st1 -> return (CommandQuit st1) - --- | Compute the replacement value for the given expansion variable. -commandExpansion :: - Maybe Text {- ^ disconnect time -} -> - ClientState {- ^ client state -} -> - Text {- ^ expansion variable -} -> - Maybe Text {- ^ expansion value -} -commandExpansion discoTime st v = - case v of - "network" -> views clientFocus focusNetwork st - "channel" -> previews (clientFocus . _ChannelFocus . _2) idText st - "nick" -> do net <- views clientFocus focusNetwork st - cs <- preview (clientConnection net) st - return (views csNick idText cs) - "disconnect" -> discoTime - _ -> Nothing - - --- | Respond to the TAB key being pressed. This can dispatch to a command --- specific completion mode when relevant. Otherwise this will complete --- input based on the users of the channel related to the current buffer. -tabCompletion :: - Bool {- ^ reversed -} -> - ClientState {- ^ client state -} -> - IO CommandResult {- ^ command result -} -tabCompletion isReversed st = - case dropWhile (' ' ==) $ snd $ clientLine st of - '/':command -> executeCommand (Just isReversed) command st - _ -> nickTabCompletion isReversed st - --- | Treat the current text input as a chat message and send it. -executeChat :: - String {- ^ chat message -} -> - ClientState {- ^ client state -} -> - IO CommandResult {- ^ command result -} -executeChat msg st = - case view clientFocus st of - ChannelFocus network channel - | Just !cs <- preview (clientConnection network) st -> - do now <- getZonedTime - let msgTxt = Text.pack $ takeWhile (/='\n') msg - tgtTxt = idText channel - - (st1,allow) <- clientChatExtension network tgtTxt msgTxt st - - when allow (sendMsg cs (ircPrivmsg tgtTxt msgTxt)) - - let myNick = UserInfo (view csNick cs) "" "" - entry = ClientMessage - { _msgTime = now - , _msgNetwork = network - , _msgBody = IrcBody (Privmsg myNick channel msgTxt) } - commandSuccess $! recordChannelMessage network channel entry st1 - - _ -> commandFailureMsg "cannot send chat messages to this window" st - - --- | Parse and execute the given command. When the first argument is Nothing --- the command is executed, otherwise the first argument is the cursor --- position for tab-completion -executeCommand :: - Maybe Bool {- ^ tab-completion direction -} -> - String {- ^ command -} -> - ClientState {- ^ client state -} -> - IO CommandResult {- ^ command result -} - -executeCommand (Just isReversed) _ st - | Just st' <- commandNameCompletion isReversed st = commandSuccess st' - -executeCommand tabCompleteReversed str st = - let (cmd, rest) = break (==' ') str - cmdTxt = Text.toLower (Text.pack cmd) - - finish spec exec tab = - case tabCompleteReversed of - Just isReversed -> tab isReversed st rest - Nothing -> - case parse st spec rest of - Nothing -> commandFailureMsg "bad command arguments" st - Just arg -> exec st arg - in - case recognize cmdTxt commands of - - Exact Command{cmdImplementation=impl, cmdArgumentSpec=argSpec} -> - case impl of - ClientCommand exec tab -> - finish argSpec exec tab - - NetworkCommand exec tab - | Just network <- views clientFocus focusNetwork st - , Just cs <- preview (clientConnection network) st -> - finish argSpec (exec cs) (\x -> tab x cs) - | otherwise -> commandFailureMsg "command requires focused network" st - - ChannelCommand exec tab - | ChannelFocus network channelId <- view clientFocus st - , Just cs <- preview (clientConnection network) st - , isChannelIdentifier cs channelId -> - finish argSpec (exec channelId cs) (\x -> tab x channelId cs) - | otherwise -> commandFailureMsg "command requires focused channel" st - - ChatCommand exec tab - | ChannelFocus network channelId <- view clientFocus st - , Just cs <- preview (clientConnection network) st -> - finish argSpec (exec channelId cs) (\x -> tab x channelId cs) - | otherwise -> commandFailureMsg "command requires focused chat window" st - - _ -> case tabCompleteReversed of - Just isReversed -> nickTabCompletion isReversed st - Nothing -> commandFailureMsg "unknown command" st - - --- | Expands each alias to have its own copy of the command callbacks -expandAliases :: [Command] -> [(Text,Command)] -expandAliases xs = - [ (name, cmd) | cmd <- xs, name <- toList (cmdNames cmd) ] - - --- | Map of built-in client commands to their implementations, tab completion --- logic, and argument structures. -commands :: Recognizer Command -commands = fromCommands (expandAliases (concatMap cmdSectionCmds commandsList)) - - --- | Raw list of commands in the order used for @/help@ -commandsList :: [CommandSection] -commandsList = - - ------------------------------------------------------------------------ - [ CommandSection "Client commands" - ------------------------------------------------------------------------ - - [ Command - (pure "exit") - (pure ()) - "Exit the client immediately.\n" - $ ClientCommand cmdExit noClientTab - - , Command - (pure "reload") - (optionalArg (simpleToken "[filename]")) - "Reload the client configuration file.\n\ - \\n\ - \If \^Bfilename\^B is provided it will be used to reload.\n\ - \Otherwise the previously loaded configuration file will be reloaded.\n" - $ ClientCommand cmdReload tabReload - - , Command - (pure "extension") - (liftA2 (,) (simpleToken "extension") (remainingArg "arguments")) - "Calls the process_command callback of the given extension.\n\ - \\n\ - \\^Bextension\^B should be the name of the loaded extension.\n" - $ ClientCommand cmdExtension simpleClientTab - - , Command - (pure "palette") - (pure ()) - "Show the current palette settings and a color chart to help pick new colors.\n" - $ ClientCommand cmdPalette noClientTab - - , Command - (pure "digraphs") - (pure ()) - "\^BDescription:\^B\n\ - \\n\ - \ Show the table of digraphs. A digraph is a pair of characters\n\ - \ can be used together to represent an uncommon character. Type\n\ - \ the two-character digraph corresponding to the desired output\n\ - \ character and then press M-k (default binding).\n\ - \\n\ - \ Note that the digraphs list is searchable with /grep.\n\ - \\n\ - \\^BSee also:\^B grep\n" - $ ClientCommand cmdDigraphs noClientTab - - , Command - (pure "keymap") - (pure ()) - "Show the key binding map.\n\ - \\n\ - \Key bindings can be changed in configuration file. See `glirc2 --config-format`.\n" - $ ClientCommand cmdKeyMap noClientTab - - , Command - (pure "rtsstats") - (pure ()) - "Show the GHC RTS statistics.\n" - $ ClientCommand cmdRtsStats noClientTab - - , Command - (pure "exec") - (remainingArg "arguments") - "Execute a command synchnonously sending the to a configuration destination.\n\ - \\n\ - \\^Barguments\^B: [-n[network]] [-c[channel]] [-i input] command [arguments...]\n\ - \\n\ - \When \^Binput\^B is specified it is sent to the stdin.\n\ - \\n\ - \When neither \^Bnetwork\^B nor \^Bchannel\^B are specified output goes to client window (*).\n\ - \When \^Bnetwork\^B is specified output is sent as raw IRC traffic to the network.\n\ - \When \^Bchannel\^B is specified output is sent as chat to the given channel on the current network.\n\ - \When \^Bnetwork\^B and \^Bchannel\^B are specified output is sent as chat to the given channel on the given network.\n\ - \\n\ - \\^Barguments\^B is divided on spaces into words before being processed\ - \ by getopt. Use Haskell string literal syntax to create arguments with\ - \ escaped characters and spaces inside.\n\ - \\n" - $ ClientCommand cmdExec simpleClientTab - - , Command - (pure "url") - optionalNumberArg - "Open a URL seen in chat.\n\ - \\n\ - \The URL is opened using the executable configured under \^Burl-opener\^B.\n\ - \\n\ - \When this command is active in the textbox, chat messages are filtered to\ - \ only show ones with URLs.\n\ - \\n\ - \When \^Bnumber\^B is omitted it defaults to \^B1\^B. The number selects the\ - \ URL to open counting back from the most recent.\n" - $ ClientCommand cmdUrl noClientTab - - , Command - (pure "cert") - (pure ()) - "Show the TLS certificate for the current connection.\n" - $ NetworkCommand cmdCert noNetworkTab - - , Command - (pure "dump") - (simpleToken "filename") - "Dump current buffer to file.\n" - $ ClientCommand cmdDump simpleClientTab - - , Command - (pure "help") - (optionalArg (simpleToken "[command]")) - "Show command documentation.\n\ - \\n\ - \When \^Bcommand\^B is omitted a list of all commands is displayed.\n\ - \When \^Bcommand\^B is specified detailed help for that command is shown.\n" - $ ClientCommand cmdHelp tabHelp - - ------------------------------------------------------------------------ - ] , CommandSection "View toggles" - ------------------------------------------------------------------------ - - [ Command - (pure "toggle-detail") - (pure ()) - "Toggle detailed message view.\n" - $ ClientCommand cmdToggleDetail noClientTab - - , Command - (pure "toggle-activity-bar") - (pure ()) - "Toggle detailed detailed activity information in status bar.\n" - $ ClientCommand cmdToggleActivityBar noClientTab - - , Command - (pure "toggle-show-ping") - (pure ()) - "Toggle visibility of ping round-trip time.\n" - $ ClientCommand cmdToggleShowPing noClientTab - - , Command - (pure "toggle-metadata") - (pure ()) - "Toggle visibility of metadata in chat windows.\n" - $ ClientCommand cmdToggleMetadata noClientTab - - , Command - (pure "toggle-layout") - (pure ()) - "Toggle multi-window layout mode.\n" - $ ClientCommand cmdToggleLayout noClientTab - - ------------------------------------------------------------------------ - ] , CommandSection "Connection commands" - ------------------------------------------------------------------------ - - [ Command - (pure "connect") - (simpleToken "network") - "Connect to \^Bnetwork\^B by name.\n\ - \\n\ - \If no name is configured the hostname is the 'name'.\n" - $ ClientCommand cmdConnect tabConnect - - , Command - (pure "reconnect") - (pure ()) - "Reconnect to the current network.\n" - $ ClientCommand cmdReconnect noClientTab - - , Command - (pure "disconnect") - (pure ()) - "Immediately terminate the current network connection.\n\ - \\n\ - \See also: /quit /exit\n" - $ NetworkCommand cmdDisconnect noNetworkTab - - , Command - (pure "quit") - (remainingArg "reason") - "Gracefully disconnect the current network connection.\n\ - \\n\ - \\^Breason\^B: optional quit reason\n\ - \\n\ - \See also: /disconnect /exit\n" - $ NetworkCommand cmdQuit simpleNetworkTab - - ------------------------------------------------------------------------ - ] , CommandSection "Window management" - ------------------------------------------------------------------------ - - [ Command - (pure "focus") - (liftA2 (,) (simpleToken "network") (optionalArg (simpleToken "[target]"))) - "Change the focused window.\n\ - \\n\ - \When only \^Bnetwork\^B is specified this switches to the network status window.\n\ - \When \^Bnetwork\^B and \^Btarget\^B are specified this switches to that chat window.\n\ - \\n\ - \Nickname and channels can be specified in the \^Btarget\^B parameter.\n\ - \See also: /query (aliased /c /channel) to switch to a target on the current network.\n" - $ ClientCommand cmdFocus tabFocus - - , Command - ("query" :| ["q"]) - (liftA2 (,) (simpleToken "target") (remainingArg "message")) - "\^BParameters:\^B\n\ - \\n\ - \ target: Focus name\n\ - \ message: Optional message\n\ - \\n\ - \\^BDescription:\^B\n\ - \\n\ - \ This command switches the client focus to the given\n\ - \ target and optionally sends a message to that target.\n\ - \\n\ - \ Channel: \^_#channel\^_\n\ - \ Channel: \^_network\^_:\^_#channel\^_\n\ - \ User: \^_nick\^_\n\ - \ User: \^_network\^_:\^_nick\^_\n\ - \\n\ - \\^BExamples:\^B\n\ - \\n\ - \ /q fn:#haskell\n\ - \ /q #haskell\n\ - \ /q lambdabot @messages\n\ - \ /q irc_friend How are you?\n\ - \\n\ - \\^BSee also:\^B msg channel focus\n" - $ ClientCommand cmdQuery simpleClientTab - - , Command - ("c" :| ["channel"]) - (simpleToken "focus") - "\^BParameters:\^B\n\ - \\n\ - \ focuses: Focus name\n\ - \\n\ - \\^BDescription:\^B\n\ - \\n\ - \ This command sets the current window focus. When\n\ - \ no network is specified, the current network will\n\ - \ be used.\n\ - \\n\ - \ Client: *\n\ - \ Network: \^_network\^_:\n\ - \ Channel: \^_#channel\^_\n\ - \ Channel: \^_network\^_:\^_#channel\^_\n\ - \ User: \^_nick\^_\n\ - \ User: \^_network\^_:\^_nick\^_\n\ - \\n\ - \\^BExamples:\^B\n\ - \\n\ - \ /c fn:#haskell\n\ - \ /c #haskell\n\ - \ /c fn:\n\ - \ /c *:\n\ - \\n\ - \\^BSee also:\^B focus\n" - $ ClientCommand cmdChannel tabChannel - - , Command - (pure "clear") - (optionalArg (liftA2 (,) (simpleToken "[network]") (optionalArg (simpleToken "[channel]")))) - "Clear a window.\n\ - \\n\ - \If no arguments are provided the current window is cleared.\n\ - \If \^Bnetwork\^B is provided the that network window is cleared.\n\ - \If \^Bnetwork\^B and \^Bchannel\^B are provided that chat window is cleared.\n\ - \If \^Bnetwork\^B is provided and \^Bchannel\^B is \^B*\^O all windows for that network are cleared.\n\ - \\n\ - \If a window is cleared and no longer active that window will be removed from the client.\n" - $ ClientCommand cmdClear tabFocus - - , Command - (pure "windows") - (optionalArg (simpleToken "[kind]")) - "Show a list of all windows with an optional argument to limit the kinds of windows listed.\n\ - \\n\ - \\^Bkind\^O: one of \^Bnetworks\^O, \^Bchannels\^O, \^Busers\^O\n\ - \\n" - $ ClientCommand cmdWindows tabWindows - - , Command - (pure "splits") - (remainingArg "focuses") - "\^BParameters:\^B\n\ - \\n\ - \ focuses: List of focus names\n\ - \\n\ - \\^BDescription:\^B\n\ - \\n\ - \ This command sents the set of focuses that will always\n\ - \ be visible, even when unfocused. When the client is focused\n\ - \ to an active network, the network can be omitted when\n\ - \ specifying a focus. If no focuses are listed, they will\n\ - \ all be cleared.\n\ - \\n\ - \ Client: *\n\ - \ Network: \^_network\^_:\n\ - \ Channel: \^_#channel\^_\n\ - \ Channel: \^_network\^_:\^_#channel\^_\n\ - \ User: \^_nick\^_\n\ - \ User: \^_network\^_:\^_nick\^_\n\ - \\n\ - \\^BExamples:\^B\n\ - \\n\ - \ /splits * fn:#haskell fn:chanserv\n\ - \ /splits #haskell #haskell-lens nickserv\n\ - \ /splits\n\ - \\n\ - \\^BSee also:\^B splits+, splits-\n" - $ ClientCommand cmdSplits tabSplits - - , Command - (pure "splits+") - (remainingArg "focuses") - "Add windows to the splits list. Omit the list of focuses to add the\ - \ current window.\n\ - \\n\ - \\^Bfocuses\^B: space delimited list of focus names.\n\ - \\n\ - \Client: *\n\ - \Network: \^BNETWORK\^B\n\ - \Channel: \^BNETWORK\^B:\^B#CHANNEL\^B\n\ - \User: \^BNETWORK\^B:\^BNICK\^B\n\ - \\n\ - \If the network part is omitted, the current network will be used.\n" - $ ClientCommand cmdSplitsAdd tabSplits - - , Command - (pure "splits-") - (remainingArg "focuses") - "Remove windows from the splits list. Omit the list of focuses to\ - \ remove the current window.\n\ - \\n\ - \\^Bfocuses\^B: space delimited list of focus names.\n\ - \\n\ - \Client: *\n\ - \Network: \^BNETWORK\^B\n\ - \Channel: \^BNETWORK\^B:\^B#CHANNEL\^B\n\ - \User: \^BNETWORK\^B:\^BNICK\^B\n\ - \\n\ - \If the network part is omitted, the current network will be used.\n" - $ ClientCommand cmdSplitsDel tabActiveSplits - - , Command - (pure "ignore") - (remainingArg "masks") - "\^BParameters:\^B\n\ - \\n\ - \ masks: List of masks\n\ - \\n\ - \\^BDescription:\^B\n\ - \\n\ - \ Toggle the soft-ignore on each of the space-delimited given\n\ - \ nicknames. Ignores can use \^B*\^B (many) and \^B?\^B (one) wildcards.\n\ - \ Masks can be of the form: nick[[!user]@host]\n\ - \ Masks use a case-insensitive comparison.\n\ - \\n\ - \ If no masks are specified the current ignore list is displayed.\n\ - \\n\ - \\^BExamples:\^B\n\ - \\n\ - \ /ignore\n\ - \ /ignore nick1 nick2 nick3\n\ - \ /ignore nick@host\n\ - \ /ignore nick!user@host\n\ - \ /ignore *@host\n\ - \ /ignore *!baduser@*\n" - $ ClientCommand cmdIgnore tabIgnore - - , Command - (pure "grep") - (remainingArg "regular-expression") - "Set the persistent regular expression.\n\ - \\n\ - \\^BFlags:\^B\n\ - \ -An Show n messages after match\n\ - \ -Bn Show n messages before match\n\ - \ -Cn Show n messages before and after match\n\ - \ -i Case insensitive match\n\ - \ -- Stop processing flags\n\ - \\n\ - \Clear the regular expression by calling this without an argument.\n\ - \\n\ - \\^B/grep\^O is case-sensitive.\n" - $ ClientCommand cmdGrep simpleClientTab - - , Command - (pure "mentions") - (pure ()) - "Show a list of all message that were highlighted as important.\n\ - \\n\ - \When using \^B/grep\^B the important messages are those matching\n\ - \the regular expression instead.\n" - $ ClientCommand cmdMentions noClientTab - - ------------------------------------------------------------------------ - ] , CommandSection "IRC commands" - ------------------------------------------------------------------------ - - [ Command - ("join" :| ["j"]) - (liftA2 (,) (simpleToken "channels") (optionalArg (simpleToken "[keys]"))) - "\^BParameters:\^B\n\ - \\n\ - \ channels: Comma-separated list of channels\n\ - \ keys: Comma-separated list of keys\n\ - \\n\ - \\^BDescription:\^B\n\ - \\n\ - \ Join the given channels. When keys are provided, they should\n\ - \ occur in the same order as the channels.\n\ - \\n\ - \\^BExamples:\^B\n\ - \\n\ - \ /join #friends\n\ - \ /join #secret thekey\n\ - \ /join #secret1,#secret2 key1,key2\n\ - \\n\ - \\^BSee also:\^B channel, clear, part\n" - $ NetworkCommand cmdJoin simpleNetworkTab - - , Command - (pure "part") - (remainingArg "reason") - "\^BParameters:\^B\n\ - \\n\ - \ reason: Optional message sent to channel as part reason\ - \\n\ - \\^BDescription:\^B\n\ - \\n\ - \ Part from the current channel.\n\ - \\n\ - \\^BExamples:\^B\n\ - \\n\ - \ /part\n\ - \ /part It's not me, it's you\n\ - \\n\ - \\^BSee also:\^B clear, join, quit\n" - $ ChannelCommand cmdPart simpleChannelTab - - , Command - (pure "msg") - (liftA2 (,) (simpleToken "target") (remainingArg "message")) - "\^BParameters:\^B\n\ - \\n\ - \ target: Comma-separated list of nicknames and channels\n\ - \ message: Formatted message body\n\ - \\n\ - \\^BDescription:\^B\n\ - \\n\ - \ Send a chat message to a user or a channel. On servers\n\ - \ with STATUSMSG support, the channel name can be prefixed\n\ - \ with a sigil to restrict the recipients to those with the\n\ - \ given mode.\n\ - \\n\ - \\^BExamples:\^B\n\ - \\n\ - \ /msg buddy I'm sending you a message.\n\ - \ /msg #friends This message is for the whole channel.\n\ - \ /msg him,her I'm chatting with two people.\n\ - \ /msg @#users This message is only for ops!\n\ - \\n\ - \\^BSee also:\^B notice, me, say\n" - $ NetworkCommand cmdMsg simpleNetworkTab - - , Command - (pure "me") - (remainingArg "message") - "\^BParameters:\^B\n\ - \\n\ - \ message: Body of action message\n\ - \\n\ - \\^BDescription:\^B\n\ - \\n\ - \ Sends an action message to the currently focused channel.\n\ - \ Most clients will render these messages prefixed with\n\ - \ only your nickname as though describing an action.\n\ - \\n\ - \\^BExamples:\^B\n\ - \\n\ - \ /me shrugs\n\ - \\n\ - \\^BSee also:\^B notice, msg, say\n" - $ ChatCommand cmdMe simpleChannelTab - - , Command - (pure "say") - (remainingArg "message") - "\^BParameters:\^B\n\ - \\n\ - \ message: Body of message\n\ - \\n\ - \\^BDescription:\^B\n\ - \\n\ - \ Send a message to the current chat window. This can be useful\n\ - \ for sending a chat message with a leading '/' to the current\n\ - \ chat window.\n\ - \\n\ - \\^BExamples:\^B\n\ - \\n\ - \ /say /help is the right place to start!\n\ - \\n\ - \\^BSee also:\^B notice, me, msg\n" - $ ChatCommand cmdSay simpleChannelTab - - , Command - (pure "notice") - (liftA2 (,) (simpleToken "target") (remainingArg "message")) - "\^BParameters:\^B\n\ - \\n\ - \ target: Comma-separated list of nicknames and channels\n\ - \ message: Formatted message body\n\ - \\n\ - \\^BDescription:\^B\n\ - \\n\ - \ Send a chat notice to a user or a channel. On servers\n\ - \ with STATUSMSG support, the channel name can be prefixed\n\ - \ with a sigil to restrict the recipients to those with the\n\ - \ given mode. Notice messages were originally intended to be\n\ - \ used by bots. Different clients will render these in different\n\ - \ ways.\n\ - \\n\ - \\^BExamples:\^B\n\ - \\n\ - \ /notice buddy I'm sending you a message.\n\ - \ /notice #friends This message is for the whole channel.\n\ - \ /notice him,her I'm chatting with two people.\n\ - \ /notice @#users This message is only for ops!\n\ - \\n\ - \\^BSee also:\^B me, msg, say\n" - $ NetworkCommand cmdNotice simpleNetworkTab - - , Command - (pure "ctcp") - (liftA3 (,,) (simpleToken "target") (simpleToken "command") (remainingArg "arguments")) - "\^BParameters:\^B\n\ - \\n\ - \ target: Comma-separated list of nicknames and channels\n\ - \ command: CTCP command name\n\ - \ arguments: CTCP command arguments\n\ - \\n\ - \\^BDescription:\^B\n\ - \\n\ - \ Client-to-client protocol (CTCP) commands can be used\n\ - \ to query information from another user's client application\n\ - \ directly. Common CTCP commands include: ACTION, PING, VERSION,\n\ - \ USERINFO, CLIENTINFO, and TIME. glirc does not automatically\n\ - \ respond to CTCP commands.\n\ - \\n\ - \\^BExamples:\^B\n\ - \\n\ - \ /ctcp myfriend VERSION\n\ - \ /ctcp myfriend CLIENTINFO\n" - $ NetworkCommand cmdCtcp simpleNetworkTab - - , Command - (pure "nick") - (simpleToken "nick") - "\^BParameters:\^B\n\ - \\n\ - \ nick: New nickname\n\ - \\n\ - \\^BDescription:\^B\n\ - \\n\ - \ Change your nickname on the currently focused server.\n\ - \\n\ - \\^BExamples:\^B\n\ - \\n\ - \ /nick guest123\n\ - \ /nick better_nick\n" - $ NetworkCommand cmdNick simpleNetworkTab - - , Command - (pure "away") - (remainingArg "message") - "\^BParameters:\^B\n\ - \\n\ - \ message: Optional away message\n\ - \\n\ - \\^BDescription:\^B\n\ - \\n\ - \ Change your nickname on the currently focused server.\n\ - \ Omit the message parameter to clear your away status.\n\ - \ The away message is only used by the server to update\n\ - \ status in /whois and to provide automated responses.\n\ - \ It is not used by this client directly.\n\ - \\n\ - \\^BExamples:\^B\n\ - \\n\ - \ /away\n\ - \ /away Out getting some sun\n" - $ NetworkCommand cmdAway simpleNetworkTab - - , Command - ("users" :| ["names"]) - (pure ()) - "\^BDescription:\^B\n\ - \\n\ - \ Show the user list for the current channel.\n\ - \ Detailed view (default key F2) shows full hostmask.\n\ - \ Hostmasks can be populated with /who #channel.\n\ - \ Press ESC to exit the userlist.\n\ - \\n\ - \\^BSee also:\^B channelinfo, masks\n" - $ ChannelCommand cmdUsers noChannelTab - - , Command - (pure "channelinfo") - (pure ()) - "\^BDescription:\^B\n\ - \\n\ - \ Show information about the current channel.\n\ - \ Press ESC to exit the channel info window.\n\ - \\n\ - \ Information includes topic, creation time, URL, and modes.\n\ - \\n\ - \\^BSee also:\^B masks, mode, topic, users\n" - $ ChannelCommand cmdChannelInfo noChannelTab - - , Command - (pure "quote") - (remainingArg "raw IRC command") - "Send a raw IRC command.\n" - $ NetworkCommand cmdQuote simpleNetworkTab - - , Command - (pure "dcc") - (liftA2 (,) (optionalArg (simpleToken "[accept|cancel|clear|resume]")) - optionalNumberArg) - "Main access to the DCC subsystem with the following subcommands:\n\n\ - \ /dcc : Access to a list of pending offer and downloads\n\ - \ /dcc accept #n : start downloading the #n pending offer\n\ - \ /dcc resume #n : same as accept but appending to the file on `download-dir`\n\ - \ /dcc clear #n : remove the #n offer from the list \n\ - \ /dcc cancel #n : cancel the download #n \n\n" - $ ClientCommand cmdDcc noClientTab - ------------------------------------------------------------------------ - ] , CommandSection "IRC queries" - ------------------------------------------------------------------------ - - [ Command - (pure "who") - (remainingArg "arguments") - "Send WHO query to server with given arguments.\n" - $ NetworkCommand cmdWho simpleNetworkTab - - , Command - (pure "whois") - (remainingArg "arguments") - "Send WHOIS query to server with given arguments.\n" - $ NetworkCommand cmdWhois simpleNetworkTab - - , Command - (pure "whowas") - (remainingArg "arguments") - "Send WHOWAS query to server with given arguments.\n" - $ NetworkCommand cmdWhowas simpleNetworkTab - - , Command - (pure "ison") - (remainingArg "arguments") - "Send ISON query to server with given arguments.\n" - $ NetworkCommand cmdIson simpleNetworkTab - - , Command - (pure "userhost") - (remainingArg "arguments") - "Send USERHOST query to server with given arguments.\n" - $ NetworkCommand cmdUserhost simpleNetworkTab - - , Command - (pure "time") - (optionalArg (simpleToken "[servername]")) - "Send TIME query to server with given arguments.\n" - $ NetworkCommand cmdTime simpleNetworkTab - - , Command - (pure "stats") - (remainingArg "arguments") - "Send STATS query to server with given arguments.\n" - $ NetworkCommand cmdStats simpleNetworkTab - - , Command - (pure "lusers") - (optionalArg (liftA2 (,) (simpleToken "mask") (optionalArg (simpleToken "[servername]")))) - "Send LUSERS query to server with given arguments.\n" - $ NetworkCommand cmdLusers simpleNetworkTab - - , Command - (pure "motd") (optionalArg (simpleToken "[servername]")) - "Send MOTD query to server.\n" - $ NetworkCommand cmdMotd simpleNetworkTab - - , Command - (pure "admin") (optionalArg (simpleToken "[servername]")) - "Send ADMIN query to server.\n" - $ NetworkCommand cmdAdmin simpleNetworkTab - - , Command - (pure "rules") (optionalArg (simpleToken "[servername]")) - "Send RULES query to server.\n" - $ NetworkCommand cmdRules simpleNetworkTab - - , Command - (pure "info") (pure ()) - "Send INFO query to server.\n" - $ NetworkCommand cmdInfo noNetworkTab - - , Command - (pure "list") (remainingArg "arguments") - "Send LIST query to server.\n" - $ NetworkCommand cmdList simpleNetworkTab - - , Command - (pure "version") (optionalArg (simpleToken "[servername]")) - "Send VERSION query to server.\n" - $ NetworkCommand cmdVersion simpleNetworkTab - - ------------------------------------------------------------------------ - ] , CommandSection "IRC channel management" - ------------------------------------------------------------------------ - - [ Command - (pure "mode") - (fromMaybe [] <$> optionalArg (extensionArg "[modes]" modeParamArgs)) - "Sets IRC modes.\n\ - \\n\ - \Examples:\n\ - \Setting a ban: /mode +b *!*@hostname\n\ - \Removing a quiet: /mode -q *!*@hostname\n\ - \Voicing two users: /mode +vv user1 user2\n\ - \Demoting an op to voice: /mode +v-o user1 user1\n\ - \\n\ - \When executed in a network window, mode changes are applied to your user.\n\ - \When executed in a channel window, mode changes are applied to the channel.\n\ - \\n\ - \This command has parameter sensitive tab-completion.\n\ - \\n\ - \See also: /masks /channelinfo\n" - $ NetworkCommand cmdMode tabMode - - , Command - (pure "masks") - (simpleToken "mode") - "Show mask lists for current channel.\n\ - \\n\ - \Common \^Bmode\^B values:\n\ - \\^Bb\^B: bans\n\ - \\^Bq\^B: quiets\n\ - \\^BI\^B: invite exemptions (op view only)\n\ - \\^Be\^B: ban exemption (op view only)s\n\ - \\n\ - \To populate the mask lists for the first time use: /mode \^Bmode\^B\n\ - \\n\ - \See also: /mode\n" - $ ChannelCommand cmdMasks noChannelTab - - , Command - (pure "invite") - (simpleToken "nick") - "Invite a user to the current channel.\n" - $ ChannelCommand cmdInvite simpleChannelTab - - , Command - (pure "topic") - (remainingArg "message") - "Set the topic on the current channel.\n\ - \\n\ - \Tab-completion with no \^Bmessage\^B specified will load the current topic for editing.\n" - $ ChannelCommand cmdTopic tabTopic - - , Command - (pure "kick") - (liftA2 (,) (simpleToken "nick") (remainingArg "reason")) - "Kick a user from the current channel.\n\ - \\n\ - \See also: /kickban /remove\n" - $ ChannelCommand cmdKick simpleChannelTab - - , Command - (pure "kickban") - (liftA2 (,) (simpleToken "nick") (remainingArg "reason")) - "Ban and kick a user from the current channel.\n\ - \\n\ - \Users are banned by hostname match.\n\ - \See also: /kick /remove\n" - $ ChannelCommand cmdKickBan simpleChannelTab - - , Command - (pure "remove") - (liftA2 (,) (simpleToken "nick") (remainingArg "reason")) - "Remove a user from the current channel.\n\ - \\n\ - \Remove works like /kick except it results in a PART.\n\ - \See also: /kick /kickban\n" - $ ChannelCommand cmdRemove simpleChannelTab - - , Command - (pure "knock") - (liftA2 (,) (simpleToken "channel") (remainingArg "message")) - "Request entry to an invite-only channel.\n" - $ NetworkCommand cmdKnock simpleNetworkTab - - ------------------------------------------------------------------------ - ] , CommandSection "ZNC Support" - ------------------------------------------------------------------------ - - [ Command - (pure "znc") - (remainingArg "arguments") - "Send command directly to ZNC.\n\ - \\n\ - \The advantage of this over /msg is that responses are not broadcast to call clients.\n" - $ NetworkCommand cmdZnc simpleNetworkTab - - , Command - (pure "znc-playback") - (optionalArg (liftA2 (,) (simpleToken "[time]") (optionalArg (simpleToken "[date]")))) - "Request playback from the ZNC 'playback' module.\n\ - \\n\ - \\^Btime\^B determines the time to playback since.\n\ - \\^Bdate\^B determines the date to playback since.\n\ - \\n\ - \When both \^Btime\^B and \^Bdate\^B are omitted, all playback is requested.\n\ - \When both \^Bdate\^B is omitted it is defaulted the most recent date in the past that makes sense.\n\ - \\n\ - \Time format: HOURS:MINUTES (example: 7:00)\n\ - \Date format: YEAR-MONTH-DAY (example: 2016-06-16)\n\ - \\n\ - \Note that the playback module is not installed in ZNC by default!\n" - $ NetworkCommand cmdZncPlayback noNetworkTab - - ] , CommandSection "Network operator commands" - - [ Command - (pure "oper") - (liftA2 (,) (simpleToken "user") (simpleToken "password")) - "Authenticate as a server operator.\n" - $ NetworkCommand cmdOper noNetworkTab - - , Command - (pure "kill") - (liftA2 (,) (simpleToken "client") (remainingArg "reason")) - "Kill a client connection to the server.\n" - $ NetworkCommand cmdKill simpleNetworkTab - - , Command - (pure "kline") - (liftA3 (,,) (simpleToken "minutes") (simpleToken "user@host") (remainingArg "reason")) - "Ban a client from the server.\n" - $ NetworkCommand cmdKline simpleNetworkTab - - , Command - (pure "unkline") - (simpleToken "user@host") - "Unban a client from the server.\n" - $ NetworkCommand cmdUnkline simpleNetworkTab - - , Command - (pure "testline") - (simpleToken "[[nick!]user@]host") - "Check matching I/K/D lines for a [[nick!]user@]host\n" - $ NetworkCommand cmdTestline simpleNetworkTab - - , Command - (pure "testmask") - (liftA2 (,) (simpleToken "[nick!]user@host") (remainingArg "[gecos]")) - "Test how many local and global clients match a mask.\n" - $ NetworkCommand cmdTestmask simpleNetworkTab - - , Command - (pure "masktrace") - (liftA2 (,) (simpleToken "[nick!]user@host") (remainingArg "[gecos]")) - "Outputs a list of local users matching the given masks.\n" - $ NetworkCommand cmdMasktrace simpleNetworkTab - - , Command - (pure "trace") - (optionalArg (liftA2 (,) (simpleToken "[server | nick]") (optionalArg (simpleToken "[server]")))) - "Outputs a list users on a server.\n" - $ NetworkCommand cmdTrace simpleNetworkTab - - , Command - (pure "map") - (pure ()) - "Display network map.\n" - $ NetworkCommand cmdMap simpleNetworkTab - - , Command - (pure "links") - (remainingArg "arguments") - "Send LINKS query to server with given arguments.\n" - $ NetworkCommand cmdLinks simpleNetworkTab - - ]] - --- | Provides no tab completion for client commands -noClientTab :: Bool -> ClientCommand String -noClientTab _ st _ = commandFailure st - --- | Provides no tab completion for network commands -noNetworkTab :: Bool -> NetworkCommand String -noNetworkTab _ _ st _ = commandFailure st - --- | Provides no tab completion for channel commands -noChannelTab :: Bool -> ChannelCommand String -noChannelTab _ _ _ st _ = commandFailure st - --- | Provides nickname based tab completion for client commands -simpleClientTab :: Bool -> ClientCommand String -simpleClientTab isReversed st _ = - nickTabCompletion isReversed st - --- | Provides nickname based tab completion for network commands -simpleNetworkTab :: Bool -> NetworkCommand String -simpleNetworkTab isReversed _ st _ = - nickTabCompletion isReversed st - --- | Provides nickname based tab completion for channel commands -simpleChannelTab :: Bool -> ChannelCommand String -simpleChannelTab isReversed _ _ st _ = - nickTabCompletion isReversed st - --- | Implementation of @/exit@ command. -cmdExit :: ClientCommand () -cmdExit st _ = return (CommandQuit st) - - -cmdToggleDetail :: ClientCommand () -cmdToggleDetail st _ = commandSuccess (over clientDetailView not st) - -cmdToggleActivityBar :: ClientCommand () -cmdToggleActivityBar st _ = commandSuccess (over clientActivityBar not st) - -cmdToggleShowPing :: ClientCommand () -cmdToggleShowPing st _ = commandSuccess (over clientShowPing not st) - -cmdToggleMetadata :: ClientCommand () -cmdToggleMetadata st _ = commandSuccess (clientToggleHideMeta st) - -cmdToggleLayout :: ClientCommand () -cmdToggleLayout st _ = commandSuccess (set clientScroll 0 (over clientLayout aux st)) - where - aux OneColumn = TwoColumn - aux TwoColumn = OneColumn - --- | When used on a channel that the user is currently --- joined to this command will clear the messages but --- preserve the window. When used on a window that the --- user is not joined to this command will delete the window. -cmdClear :: ClientCommand (Maybe (String, Maybe String)) -cmdClear st args = - case args of - Nothing -> clearFocus (view clientFocus st) - Just ("*", Nothing) -> clearFocus Unfocused - Just (network, Nothing) -> clearFocus (NetworkFocus (Text.pack network)) - Just (network, Just "*") -> clearNetworkWindows network - Just (network, Just channel) -> - clearFocus (ChannelFocus (Text.pack network) (mkId (Text.pack channel))) - where - clearNetworkWindows network - = commandSuccess - $ foldl' (flip clearFocus1) st - $ filter (\x -> focusNetwork x == Just (Text.pack network)) - $ views clientWindows Map.keys st - - clearFocus focus = commandSuccess (clearFocus1 focus st) - - clearFocus1 focus st' = focusEffect (windowEffect st') - where - windowEffect - | isActive = setWindow (Just emptyWindow) - | otherwise = setWindow Nothing - - focusEffect - | not isActive && view clientFocus st' == focus = - if has (clientWindows . ix prev) st' - then changeFocus prev - else advanceFocus - | otherwise = id - where - prev = view clientPrevFocus st - - setWindow = set (clientWindows . at focus) - - isActive = - case focus of - Unfocused -> False - NetworkFocus network -> has (clientConnection network) st' - ChannelFocus network channel -> has (clientConnection network - .csChannels . ix channel) st' - --- | Implementation of @/quote@. Parses arguments as a raw IRC command and --- sends to the current network. -cmdQuote :: NetworkCommand String -cmdQuote cs st rest = - case parseRawIrcMsg (Text.pack (dropWhile (' '==) rest)) of - Nothing -> commandFailureMsg "failed to parse raw IRC command" st - Just raw -> - do sendMsg cs raw - commandSuccess st - --- | Implementation of @/dcc [(cancel|accept|resume)] [key] -cmdDcc :: ClientCommand (Maybe String, Maybe Int) -cmdDcc st (Nothing, Nothing) = commandSuccess (changeSubfocus FocusDCC st) -cmdDcc st (Just cmd, Just key) = checkAndBranch st cmd key -cmdDcc st _ = commandFailureMsg "Invalid syntax" st - -checkAndBranch :: ClientState -> String -> Int -> IO CommandResult -checkAndBranch st cmd key - | isCancel, NotExist <- curKeyStatus - = commandFailureMsg "No such DCC entry" st - | isCancel, curKeyStatus == Pending - = commandSuccess - $ set (clientDCC . dsOffers . ix key . dccStatus) UserKilled st - | isCancel, curKeyStatus /= Downloading - = commandFailureMsg "Transfer already stopped" st - | isCancel = cancel threadId *> commandSuccess st - - | isClear, NotExist <- curKeyStatus - = commandFailureMsg "No such DCC entry" st - | isClear, curKeyStatus `elem` [Downloading, Pending] - = commandFailureMsg "Cancel the download first" st - | isClear = commandSuccess - $ set (clientDCC . dsOffers . at key) Nothing - $ set (clientDCC . dsTransfers . at key) Nothing st - - | isAcceptOrResume, curKeyStatus `elem` alreadyAcceptedSet - = commandFailureMsg "Offer already accepted" st - | isAcceptOrResume, NotExist <- curKeyStatus - = commandFailureMsg "No such DCC entry" st - | isAcceptOrResume - = do isDirectory <- doesDirectoryExist downloadPath - msize <- getFileOffset downloadPath - case (isDirectory, msize, cmd, mcs) of - (True, _, _, _) -> commandFailureMsg "DCC transfer would overwrite a directory" st - (_, Nothing, _, _) -> acceptOffer -- resume from 0 is accept - (_, _, "accept", _) -> acceptOffer -- overwrite file - (_, Just size, "resume", Just cs) -> resumeOffer size cs - _ -> commandFailureMsg "Unknown case" st - - | otherwise = commandFailureMsg "Invalid syntax" st - where - -- General - isAcceptOrResume = cmd `elem` ["accept", "resume"] - isCancel = cmd == "cancel" - isClear = cmd == "clear" - dccState = view clientDCC st - curKeyStatus = statusAtKey key dccState - alreadyAcceptedSet = [ CorrectlyFinished, UserKilled, LostConnection - , Downloading] - - -- For cancel, other cases handled on the guards - threadId = st ^?! clientDCC . dsTransfers . ix key . dtThread . _Just - - -- Common values for resume or accept - Just offer = view (clientDCC . dsOffers . at key) st -- guarded exist - updChan = view clientDCCUpdates st - downloadDir = view (clientConfig . configDownloadDir) st - downloadPath = downloadDir _dccFileName offer - mcs = preview (clientConnection (_dccNetwork offer)) st - - -- Actual workhorses for the commands - acceptOffer = - do newDCCState <- supervisedDownload downloadDir key updChan dccState - commandSuccess (set clientDCC newDCCState st) - - resumeOffer size cs = - let newOffer = offer { _dccOffset = size } - (target, txt) = resumeMsg size newOffer - st' = set (clientDCC . dsOffers . at key) (Just newOffer) st - in cmdCtcp cs st' (target, "DCC", txt) - - --- | Implementation of @/me@ -cmdMe :: ChannelCommand String -cmdMe channelId cs st rest = - do now <- getZonedTime - let actionTxt = Text.pack ("\^AACTION " ++ rest ++ "\^A") - !myNick = UserInfo (view csNick cs) "" "" - network = view csNetwork cs - entry = ClientMessage - { _msgTime = now - , _msgNetwork = network - , _msgBody = IrcBody (Ctcp myNick channelId "ACTION" (Text.pack rest)) - } - sendMsg cs (ircPrivmsg (idText channelId) actionTxt) - commandSuccess - $! recordChannelMessage network channelId entry st - --- | 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 - - sendMsg cs (ircPrivmsg tgtTxt ("\^A" <> cmdTxt <> " " <> argTxt <> "\^A")) - chatCommand - (\src tgt -> Ctcp src tgt cmdTxt argTxt) - tgtTxt cs 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 - --- | 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 - - 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 -} -> - NetworkState -> - ClientState -> - IO CommandResult -chatCommand mkmsg target cs st = - commandSuccess =<< chatCommand' mkmsg target cs st - --- | Common logic for @/msg@ and @/notice@ returning the client state -chatCommand' :: - (UserInfo -> Identifier -> IrcMsg) -> - Text {- ^ target -} -> - NetworkState -> - ClientState -> - IO ClientState -chatCommand' con targetsTxt cs st = - do now <- getZonedTime - let targetTxts = Text.split (==',') targetsTxt - targetIds = mkId <$> targetTxts - !myNick = UserInfo (view csNick cs) "" "" - network = view csNetwork cs - entries = [ (targetId, - ClientMessage - { _msgTime = now - , _msgNetwork = network - , _msgBody = IrcBody (con myNick targetId) - }) - | targetId <- targetIds ] - - return $! foldl' (\acc (targetId, entry) -> - recordChannelMessage network targetId entry acc) - st - entries - - -cmdConnect :: ClientCommand String -cmdConnect st networkStr = - do -- abort any existing connection before connecting - let network = Text.pack networkStr - st' <- addConnection 0 Nothing Nothing network =<< abortNetwork network st - commandSuccess - $ changeFocus (NetworkFocus network) st' - -cmdFocus :: ClientCommand (String, Maybe String) -cmdFocus st (network, mbChannel) - | network == "*" = commandSuccess (changeFocus Unfocused st) - | otherwise = - case mbChannel of - Nothing -> - let focus = NetworkFocus (Text.pack network) in - commandSuccess (changeFocus focus st) - Just channel -> - let focus = ChannelFocus (Text.pack network) (mkId (Text.pack channel)) in - commandSuccess - $ changeFocus focus st - - -tabWindows :: Bool -> ClientCommand String -tabWindows isReversed st _ = - simpleTabCompletion plainWordCompleteMode [] completions isReversed st - where - completions = ["networks","channels","users"] :: [Text] - - --- | Implementation of @/windows@ command. Set subfocus to Windows. -cmdWindows :: ClientCommand (Maybe String) -cmdWindows st arg = - case arg of - Nothing -> success AllWindows - Just "networks" -> success NetworkWindows - Just "channels" -> success ChannelWindows - Just "users" -> success UserWindows - _ -> commandFailureMsg errmsg st - where - errmsg = "/windows expected networks, channels, or users" - success x = - commandSuccess (changeSubfocus (FocusWindows x) st) - --- | Implementation of @/mentions@ command. Set subfocus to Mentions. -cmdMentions :: ClientCommand () -cmdMentions st _ = commandSuccess (changeSubfocus FocusMentions st) - --- | Implementation of @/palette@ command. Set subfocus to Palette. -cmdPalette :: ClientCommand () -cmdPalette st _ = commandSuccess (changeSubfocus FocusPalette st) - --- | Implementation of @/digraphs@ command. Set subfocus to Digraphs. -cmdDigraphs :: ClientCommand () -cmdDigraphs st _ = commandSuccess (changeSubfocus FocusDigraphs st) - --- | Implementation of @/keymap@ command. Set subfocus to Keymap. -cmdKeyMap :: ClientCommand () -cmdKeyMap st _ = commandSuccess (changeSubfocus FocusKeyMap st) - --- | Implementation of @/rtsstats@ command. Set subfocus to RtsStats. --- Update cached rts stats in client state. -cmdRtsStats :: ClientCommand () -cmdRtsStats st _ = - do mb <- getStats - case mb of - Nothing -> commandFailureMsg "RTS statistics not available. (Use +RTS -T)" st - Just{} -> commandSuccess $ set clientRtsStats mb - $ changeSubfocus FocusRtsStats st - --- | Implementation of @/help@ command. Set subfocus to Help. -cmdHelp :: ClientCommand (Maybe String) -cmdHelp st mb = commandSuccess (changeSubfocus focus st) - where - focus = FocusHelp (fmap Text.pack mb) - --- | Implementation of @/dump@. Writes detailed contents of focused buffer --- to the given filename. -cmdDump :: ClientCommand String -cmdDump st fp = - do res <- try (LText.writeFile fp (LText.unlines outputLines)) - case res of - Left e -> commandFailureMsg (Text.pack (displayException (e :: SomeException))) st - Right{} -> commandSuccess st - - where - focus = view clientFocus st - msgs = preview (clientWindows . ix focus . winMessages) st - outputLines = - case msgs of - Nothing -> [] - Just wls -> convert [] wls - convert acc Nil = acc - convert acc (wl :- wls) = convert (views wlFullImage imageText wl : acc) wls - --- | Tab completion for @/splits[+]@. When given no arguments this --- populates the current list of splits, otherwise it tab completes --- all of the currently available windows. -tabSplits :: Bool -> ClientCommand String -tabSplits isReversed st rest - - -- If no arguments, populate the current splits - | all (' '==) rest = - let cmd = unwords $ "/splits" - : map (Text.unpack . renderSplitFocus) currentExtras - - currentExtras = view clientExtraFocus st - newline = Edit.endLine cmd - in commandSuccess (set (clientTextBox . Edit.line) newline st) - - -- Tab complete the available windows. Accepts either fully qualified - -- window names or current network names without the ':' - | otherwise = - let completions = currentNet <> allWindows - allWindows = renderSplitFocus <$> views clientWindows Map.keys st - currentNet = case views clientFocus focusNetwork st of - Just net -> idText <$> channelWindowsOnNetwork net st - Nothing -> [] - in simpleTabCompletion plainWordCompleteMode [] completions isReversed st - - --- | Tab completion for @/splits-@. This completes only from the list of active --- entries in the splits list. -tabActiveSplits :: Bool -> ClientCommand String -tabActiveSplits isReversed st _ = - simpleTabCompletion plainWordCompleteMode [] completions isReversed st - where - completions = currentNetSplits <> currentSplits - currentSplits = renderSplitFocus <$> view clientExtraFocus st - currentNetSplits = - [ idText chan - | ChannelFocus net chan <- view clientExtraFocus st - , views clientFocus focusNetwork st == Just net - ] - - -withSplitFocuses :: - ClientState -> - String -> - ([Focus] -> IO CommandResult) -> - IO CommandResult -withSplitFocuses st str k = - case mb of - Nothing -> commandFailureMsg "unable to parse arguments" st - Just args -> k args - where - mb = traverse - (parseFocus (views clientFocus focusNetwork st)) - (words str) - --- | Parses a single focus name given a default network. --- --- The default is parameterized over an arbitrary 'Applicative' --- instance so that if you know the network you can use 'Identity' --- and if you might not, you can use 'Maybe' -parseFocus :: - Applicative f => - f Text {- ^ default network -} -> - String {- ^ @[network:]target@ -} -> - f Focus -parseFocus mbNet x = - case break (==':') x of - ("*","") -> pure Unfocused - (net,_:"") -> pure (NetworkFocus (Text.pack net)) - (net,_:chan) -> pure (ChannelFocus (Text.pack net) (mkId (Text.pack chan))) - (chan,"") -> mbNet <&> \net -> - ChannelFocus net (mkId (Text.pack chan)) - --- | Render a entry from splits back to the textual format. -renderSplitFocus :: Focus -> Text -renderSplitFocus Unfocused = "*" -renderSplitFocus (NetworkFocus x) = x <> ":" -renderSplitFocus (ChannelFocus x y) = x <> ":" <> idText y - - --- | Implementation of @/splits@ -cmdSplits :: ClientCommand String -cmdSplits st str = - withSplitFocuses st str $ \args -> - commandSuccess (setExtraFocus (nub args) st) - - --- | Implementation of @/splits+@. When no focuses are provided --- the current focus is used instead. -cmdSplitsAdd :: ClientCommand String -cmdSplitsAdd st str = - withSplitFocuses st str $ \args -> - let args' - | null args = st ^.. clientFocus - | otherwise = args - extras = nub (args' ++ view clientExtraFocus st) - - in commandSuccess (setExtraFocus extras st) - --- | Implementation of @/splits-@. When no focuses are provided --- the current focus is used instead. -cmdSplitsDel :: ClientCommand String -cmdSplitsDel st str = - withSplitFocuses st str $ \args -> - let args' - | null args = st ^.. clientFocus - | otherwise = args - extras = view clientExtraFocus st \\ args' - - in commandSuccess (setExtraFocus extras st) - - -tabHelp :: Bool -> ClientCommand String -tabHelp isReversed st _ = - simpleTabCompletion plainWordCompleteMode [] commandNames isReversed st - where - commandNames = fst <$> expandAliases (concatMap cmdSectionCmds commandsList) - -simpleTabCompletion :: - Prefix a => - WordCompletionMode {- ^ word completion mode -} -> - [a] {- ^ hints -} -> - [a] {- ^ all completions -} -> - Bool {- ^ reversed order -} -> - ClientState {- ^ client state -} -> - IO CommandResult -simpleTabCompletion mode hints completions isReversed st = - case traverseOf clientTextBox tryCompletion st of - Nothing -> commandFailure st - Just st' -> commandSuccess st' - where - tryCompletion = wordComplete mode isReversed hints completions - --- | @/connect@ tab completes known server names -tabConnect :: Bool -> ClientCommand String -tabConnect isReversed st _ = - simpleTabCompletion plainWordCompleteMode [] networks isReversed st - where - networks = views clientConnections HashMap.keys st - ++ views (clientConfig . configServers) HashMap.keys st - - --- | When tab completing the first parameter of the focus command --- the current networks are used. -tabFocus :: Bool -> ClientCommand String -tabFocus isReversed st _ = - simpleTabCompletion plainWordCompleteMode [] completions isReversed st - where - networks = map mkId $ HashMap.keys $ view clientConnections st - params = words $ uncurry take $ clientLine st - - completions = - case params of - [_cmd,_net] -> networks - [_cmd,net,_chan] -> channelWindowsOnNetwork (Text.pack net) st - _ -> [] - -cmdWhois :: NetworkCommand String -cmdWhois cs st rest = - do sendMsg cs (ircWhois (Text.pack <$> words rest)) - commandSuccess st - -cmdWho :: NetworkCommand String -cmdWho cs st rest = - do sendMsg cs (ircWho (Text.pack <$> words rest)) - commandSuccess st - -cmdWhowas :: NetworkCommand String -cmdWhowas cs st rest = - do sendMsg cs (ircWhowas (Text.pack <$> words rest)) - commandSuccess st - -cmdIson :: NetworkCommand String -cmdIson cs st rest = - do sendMsg cs (ircIson (Text.pack <$> words rest)) - commandSuccess st - -cmdUserhost :: NetworkCommand String -cmdUserhost cs st rest = - do sendMsg cs (ircUserhost (Text.pack <$> words rest)) - commandSuccess st - -cmdStats :: NetworkCommand String -cmdStats cs st rest = - do sendMsg cs (ircStats (Text.pack <$> words rest)) - commandSuccess st - -cmdLusers :: NetworkCommand (Maybe (String, 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] - commandSuccess st - -cmdMotd :: NetworkCommand (Maybe String) -cmdMotd cs st mbservername = - do sendMsg cs $ ircMotd $ case mbservername of - Just s -> Text.pack s - Nothing -> "" - commandSuccess st - -cmdAdmin :: NetworkCommand (Maybe String) -cmdAdmin cs st mbservername = - do sendMsg cs $ ircAdmin $ case mbservername of - Just s -> Text.pack s - Nothing -> "" - commandSuccess st - -cmdRules :: NetworkCommand (Maybe String) -cmdRules cs st mbservername = - do sendMsg cs $ ircRules $ - case mbservername of - Just s -> Text.pack s - Nothing -> "" - commandSuccess st - -cmdMap :: NetworkCommand () -cmdMap cs st _ = - do sendMsg cs ircMap - commandSuccess st - -cmdInfo :: NetworkCommand () -cmdInfo cs st _ = - do sendMsg cs ircInfo - commandSuccess st - -cmdVersion :: NetworkCommand (Maybe String) -cmdVersion cs st mbservername = - do sendMsg cs $ ircVersion $ case mbservername of - Just s -> Text.pack s - Nothing -> "" - commandSuccess st - -cmdList :: NetworkCommand String -cmdList cs st rest = - do sendMsg cs (ircList (Text.pack <$> words rest)) - commandSuccess st - -cmdKill :: NetworkCommand (String, String) -cmdKill cs st (client,rest) = - do sendMsg cs (ircKill (Text.pack client) (Text.pack rest)) - commandSuccess st - -cmdKline :: NetworkCommand (String, String, String) -cmdKline cs st (minutes, mask, reason) = - do sendMsg cs (ircKline (Text.pack minutes) (Text.pack mask) (Text.pack reason)) - commandSuccess st - -cmdUnkline :: NetworkCommand String -cmdUnkline cs st mask = - do sendMsg cs (ircUnkline (Text.pack mask)) - commandSuccess st - -cmdTestline :: NetworkCommand String -cmdTestline cs st mask = - do sendMsg cs (ircTestline (Text.pack mask)) - commandSuccess st - -cmdTestmask :: NetworkCommand (String, String) -cmdTestmask cs st (mask, gecos) = - do sendMsg cs (ircTestmask (Text.pack mask) (Text.pack gecos)) - commandSuccess st - -cmdMasktrace :: NetworkCommand (String, String) -cmdMasktrace cs st (mask, gecos) = - do sendMsg cs (ircMasktrace (Text.pack mask) (Text.pack gecos)) - commandSuccess st - -cmdTrace :: NetworkCommand (Maybe (String, Maybe String)) -cmdTrace cs st args = - do let argsList = - case args of - Nothing -> [] - Just (x, Nothing) -> [x] - Just (x, Just y) -> [x, y] - sendMsg cs (rawIrcMsg "TRACE" (map Text.pack argsList)) - commandSuccess st - -cmdAway :: NetworkCommand String -cmdAway cs st rest = - do sendMsg cs (ircAway (Text.pack rest)) - commandSuccess st - -cmdLinks :: NetworkCommand String -cmdLinks cs st rest = - do sendMsg cs (ircLinks (Text.pack <$> words rest)) - commandSuccess st - -cmdTime :: NetworkCommand (Maybe String) -cmdTime cs st arg = - do sendMsg cs $ ircTime $ - case arg of - Nothing -> "" - Just x -> Text.pack x - commandSuccess st - -cmdZnc :: NetworkCommand String -cmdZnc cs st rest = - do sendMsg cs (ircZnc (Text.words (Text.pack rest))) - commandSuccess st - -cmdZncPlayback :: NetworkCommand (Maybe (String, Maybe String)) -cmdZncPlayback cs st args = - case args of - - -- request everything - Nothing -> success "0" - - -- current date explicit time - Just (timeStr, Nothing) - | Just tod <- parseFormats timeFormats timeStr -> - do now <- getZonedTime - let (nowTod,t) = (zonedTimeLocalTime . localTimeTimeOfDay <<.~ tod) now - yesterday = over (zonedTimeLocalTime . localTimeDay) (addDays (-1)) - fixDay - | tod <= nowTod = id - | otherwise = yesterday - successZoned (fixDay t) - - -- explicit date and time - Just (dateStr, Just timeStr) - | Just day <- parseFormats dateFormats dateStr - , Just tod <- parseFormats timeFormats timeStr -> - do tz <- getCurrentTimeZone - successZoned ZonedTime - { zonedTimeZone = tz - , zonedTimeToLocalTime = LocalTime - { localTimeOfDay = tod - , localDay = day } } - - _ -> commandFailureMsg "unable to parse date/time arguments" st - - where - -- %k doesn't require a leading 0 for times before 10AM - timeFormats = ["%k:%M:%S","%k:%M"] - dateFormats = ["%F"] - parseFormats formats str = - asum (map (parseTimeM False defaultTimeLocale ?? str) formats) - - successZoned = success . formatTime defaultTimeLocale "%s" - - success start = - do sendMsg cs (ircZnc ["*playback", "play", "*", Text.pack start]) - commandSuccess st - -cmdMode :: NetworkCommand [String] -cmdMode cs st xs = modeCommand (Text.pack <$> xs) cs st - -cmdNick :: NetworkCommand String -cmdNick cs st nick = - do sendMsg cs (ircNick (Text.pack nick)) - commandSuccess st - -cmdPart :: ChannelCommand String -cmdPart channelId cs st rest = - do let msg = rest - sendMsg cs (ircPart channelId (Text.pack msg)) - commandSuccess st - --- | This command is equivalent to chatting without a command. The primary use --- at the moment is to be able to send a leading @/@ to chat easily. -cmdSay :: ChannelCommand String -cmdSay _ _ st rest = executeChat rest st - -cmdInvite :: ChannelCommand String -cmdInvite channelId cs st nick = - do let freeTarget = has (csChannels . ix channelId . chanModes . ix 'g') cs - cmd = ircInvite (Text.pack nick) channelId - cs' <- if freeTarget - then cs <$ sendMsg cs cmd - else sendModeration channelId [cmd] cs - commandSuccessUpdateCS cs' st - -commandSuccessUpdateCS :: NetworkState -> ClientState -> IO CommandResult -commandSuccessUpdateCS cs st = - do let network = view csNetwork cs - commandSuccess - $ setStrict (clientConnection network) cs st - -cmdTopic :: ChannelCommand String -cmdTopic channelId cs st rest = - do sendTopic channelId (Text.pack rest) cs - commandSuccess st - -tabTopic :: - Bool {- ^ reversed -} -> - ChannelCommand String -tabTopic _ channelId cs st rest - - | all (==' ') rest - , Just topic <- preview (csChannels . ix channelId . chanTopic) cs = - do let textBox = set Edit.line (Edit.endLine $ "/topic " ++ Text.unpack topic) - commandSuccess (over clientTextBox textBox st) - - | otherwise = commandFailure st - - -cmdUsers :: ChannelCommand () -cmdUsers _ _ st _ = commandSuccess (changeSubfocus FocusUsers st) - -cmdChannelInfo :: ChannelCommand () -cmdChannelInfo _ _ st _ = commandSuccess (changeSubfocus FocusInfo st) - -cmdMasks :: ChannelCommand String -cmdMasks channel cs st rest = - case rest of - [mode] | mode `elem` view (csModeTypes . modesLists) cs -> - - do let connecting = has (csPingStatus . _PingConnecting) cs - listLoaded = has (csChannels . ix channel . chanLists . ix mode) cs - unless (connecting || listLoaded) - (sendMsg cs (ircMode channel [Text.singleton mode])) - - commandSuccess (changeSubfocus (FocusMasks mode) st) - - _ -> commandFailureMsg "unknown mask mode" st - -cmdKick :: ChannelCommand (String, String) -cmdKick channelId cs st (who,reason) = - do let msg = Text.pack reason - cmd = ircKick channelId (Text.pack who) msg - cs' <- sendModeration channelId [cmd] cs - commandSuccessUpdateCS cs' st - - -cmdKickBan :: ChannelCommand (String, String) -cmdKickBan channelId cs st (who,reason) = - do let msg = Text.pack reason - - whoTxt = Text.pack who - - mask = renderUserInfo (computeBanUserInfo (mkId whoTxt) cs) - cmds = [ ircMode channelId ["b", mask] - , ircKick channelId whoTxt msg - ] - cs' <- sendModeration channelId cmds cs - commandSuccessUpdateCS cs' st - -computeBanUserInfo :: Identifier -> NetworkState -> UserInfo -computeBanUserInfo who cs = - case view (csUser who) cs of - Nothing -> UserInfo who "*" "*" - Just (UserAndHost _ host _) -> UserInfo "*" "*" host - -cmdRemove :: ChannelCommand (String, String) -cmdRemove channelId cs st (who,reason) = - do let msg = Text.pack reason - cmd = ircRemove channelId (Text.pack who) msg - cs' <- sendModeration channelId [cmd] cs - commandSuccessUpdateCS cs' st - -cmdKnock :: NetworkCommand (String, String) -cmdKnock cs st (chan,message) = - do sendMsg cs (ircKnock (Text.pack chan) (Text.pack message)) - commandSuccess st - -cmdJoin :: NetworkCommand (String, Maybe String) -cmdJoin cs st (channels, mbKeys) = - do let network = view csNetwork cs - let channelId = mkId (Text.pack (takeWhile (/=',') channels)) - sendMsg cs (ircJoin (Text.pack channels) (Text.pack <$> mbKeys)) - commandSuccess - $ changeFocus (ChannelFocus network channelId) st - --- | @/query@ command. Takes a channel or nickname and switches --- focus to that target on the current network. -cmdQuery :: ClientCommand (String, String) -cmdQuery st (target, msg) = - case parseFocus (views clientFocus focusNetwork st) target of - Just (ChannelFocus net tgt) - - | null msg -> commandSuccess st' - - | 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' - where - firstTgt = mkId (Text.takeWhile (','/=) (idText tgt)) - st' = changeFocus (ChannelFocus net firstTgt) st - - _ -> commandFailureMsg "Bad target" st - - --- | @/channel@ command. Takes a channel or nickname and switches --- focus to that target on the current network. -cmdChannel :: ClientCommand String -cmdChannel st channel = - case parseFocus (views clientFocus focusNetwork st) channel of - Just focus -> commandSuccess (changeFocus focus st) - Nothing -> commandFailureMsg "No current network" st - --- | Tab completion for @/channel@. Tab completion uses pre-existing --- windows. -tabChannel :: - Bool {- ^ reversed order -} -> - ClientCommand String -tabChannel isReversed st _ = - simpleTabCompletion plainWordCompleteMode [] completions isReversed st - where - completions = currentNet <> allWindows - allWindows = renderSplitFocus <$> views clientWindows Map.keys st - currentNet = case views clientFocus focusNetwork st of - Just net -> idText <$> channelWindowsOnNetwork net st - Nothing -> [] - --- | Return the list of identifiers for open channel windows on --- the given network name. -channelWindowsOnNetwork :: - Text {- ^ network -} -> - ClientState {- ^ client state -} -> - [Identifier] {- ^ open channel windows -} -channelWindowsOnNetwork network st = - [ chan | ChannelFocus net chan <- Map.keys (view clientWindows st) - , net == network ] - - -cmdQuit :: NetworkCommand String -cmdQuit cs st rest = - do let msg = Text.pack rest - sendMsg cs (ircQuit msg) - commandSuccess st - -cmdDisconnect :: NetworkCommand () -cmdDisconnect cs st _ = - do st' <- abortNetwork (view csNetwork cs) st - commandSuccess st' - --- | Reconnect to the currently focused network. It's possible --- that we're not currently connected to a network, so --- this is implemented as a client command. -cmdReconnect :: ClientCommand () -cmdReconnect st _ - | Just network <- views clientFocus focusNetwork st = - - do let tm = preview (clientConnection network . csLastReceived . folded) st - st' <- addConnection 0 tm Nothing network =<< abortNetwork network st - commandSuccess - $ changeFocus (NetworkFocus network) st' - - | otherwise = commandFailureMsg "command requires focused network" st - -cmdIgnore :: ClientCommand String -cmdIgnore st rest = - case mkId <$> Text.words (Text.pack rest) of - [] -> commandSuccess (changeSubfocus FocusIgnoreList st) - xs -> commandSuccess st2 - where - (newIgnores, st1) = (clientIgnores <%~ updateIgnores) st - st2 = set clientIgnoreMask (buildMask (toList newIgnores)) st1 - - updateIgnores :: HashSet Identifier -> HashSet Identifier - updateIgnores s = foldl' updateIgnore s xs - - updateIgnore s x = over (contains x) not s - --- | Complete the nickname at the current cursor position using the --- userlist for the currently focused channel (if any) -tabIgnore :: Bool {- ^ reversed -} -> ClientCommand String -tabIgnore isReversed st _ = - simpleTabCompletion mode hint completions isReversed st - where - hint = activeNicks st - completions = currentCompletionList st ++ views clientIgnores toList st - mode = currentNickCompletionMode st - --- | Implementation of @/reload@ --- --- Attempt to reload the configuration file -cmdReload :: ClientCommand (Maybe String) -cmdReload st mbPath = - do let path = mbPath <|> Just (view clientConfigPath st) - res <- loadConfiguration path - case res of - Left e -> commandFailureMsg (describeProblem e) st - Right (path',cfg) -> - do st1 <- clientStartExtensions - $ set clientConfig cfg - $ set clientConfigPath path' st - commandSuccess st1 - - where - describeProblem err = - Text.pack $ - case err of - ConfigurationReadFailed e -> "Failed to open configuration: " ++ e - ConfigurationParseFailed _ e -> "Failed to parse configuration: " ++ e - ConfigurationMalformed _ e -> "Configuration malformed: " ++ e - --- | Support file name tab completion when providing an alternative --- configuration file. --- --- /NOT IMPLEMENTED/ -tabReload :: Bool {- ^ reversed -} -> ClientCommand String -tabReload _ st _ = commandFailure st - - -modeParamArgs :: ClientState -> String -> Maybe (Args ClientState [String]) -modeParamArgs st str = - case view clientFocus st of - Unfocused -> Nothing - NetworkFocus _ -> Just (pure [str]) - ChannelFocus net _ -> - - -- determine current mode types - do cs <- preview (clientConnection net) st - let types = view csModeTypes cs - - -- parse the list of modes being set - flags <- splitModes types (Text.pack str) [] - - -- generate the argument specification - let (req,opt) = foldr (countFlags types) ([],[]) flags - return ((str:) <$> tokenList req (map (++"?") opt)) - - --- | This function computes the list of required and optional parameters --- corresponding to the flags that have been entered. -countFlags :: - ModeTypes {- ^ network's mode behaviors -} -> - (Bool, Char, Text) {- ^ polarity mode-letter unused-parameter -} -> - ([String],[String]) {- ^ required-names optional-names -} -> - ([String],[String]) {- ^ required-names optional-names -} -countFlags types (pol, flag, _) - | flag `elem` view modesLists types = addOpt - | pol && flag `elem` view modesSetArg types = addReq - | flag `elem` view modesAlwaysArg types = addReq - | elemOf (modesPrefixModes . folded . _1) flag types = addReq - | otherwise = id - where - addReq (req,opt) = ((flag:" param"):req,opt) - addOpt ([] ,opt) = ([], (flag:" param"):opt) - addOpt (req,opt) = ((flag:" param"):req,opt) - - -modeCommand :: - [Text] {- mode parameters -} -> - NetworkState -> - ClientState -> - IO CommandResult -modeCommand modes cs st = - case view clientFocus st of - - NetworkFocus _ -> - do sendMsg cs (ircMode (view csNick cs) modes) - commandSuccess st - - ChannelFocus _ chan -> - case modes of - [] -> success False [[]] - flags:params -> - case splitModes (view csModeTypes cs) flags params of - Nothing -> commandFailureMsg "failed to parse modes" st - Just parsedModes -> - success needOp (unsplitModes <$> chunksOf (view csModeCount cs) parsedModes') - where - parsedModes' - | useChanServ chan cs = filter (not . isOpMe) parsedModes - | otherwise = parsedModes - - needOp = not (all isPublicChannelMode parsedModes) - where - isOpMe (True, 'o', param) = mkId param == view csNick cs - isOpMe _ = False - - success needOp argss = - do let cmds = ircMode chan <$> argss - cs' <- if needOp - then sendModeration chan cmds cs - else cs <$ traverse_ (sendMsg cs) cmds - commandSuccessUpdateCS cs' st - - _ -> commandFailure st - -tabMode :: Bool -> NetworkCommand String -tabMode isReversed cs st rest = - case view clientFocus st of - - ChannelFocus _ channel - | flags:params <- Text.words (Text.pack rest) - , Just parsedModes <- splitModes (view csModeTypes cs) flags params - , let parsedModesWithParams = - [ (pol,mode) | (pol,mode,arg) <- parsedModes, not (Text.null arg) ] - , (pol,mode):_ <- drop (paramIndex-3) parsedModesWithParams - , let (hint, completions) = computeModeCompletion pol mode channel cs st - -> simpleTabCompletion plainWordCompleteMode hint completions isReversed st - - _ -> commandFailure st - - where - paramIndex = length $ words $ uncurry take $ clientLine st - -activeNicks :: - ClientState -> - [Identifier] -activeNicks st = - case view clientFocus st of - focus@(ChannelFocus network channel) -> - toListOf - ( clientWindows . ix focus - . winMessages . each - . wlSummary . folding summaryActor - . filtered isActive - . filtered isNotSelf ) st - where - isActive n = HashMap.member n userMap - self = preview ( clientConnection network . csNick ) st - isNotSelf n = case self of - Nothing -> True - Just s -> n /= s - userMap = view ( clientConnection network - . csChannels . ix channel - . chanUsers) st - - _ -> [] - - where - -- 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 - --- | Use the *!*@host masks of users for channel lists when setting list modes --- --- Use the channel's mask list for removing modes --- --- Use the nick list otherwise -computeModeCompletion :: - Bool {- ^ mode polarity -} -> - Char {- ^ mode -} -> - Identifier {- ^ channel -} -> - NetworkState -> - ClientState -> - ([Identifier],[Identifier]) {- ^ (hint, complete) -} -computeModeCompletion pol mode channel cs st - | mode `elem` view modesLists modeSettings = - if pol then ([],usermasks) else ([],masks) - | otherwise = (activeNicks st, nicks) - where - modeSettings = view csModeTypes cs - nicks = HashMap.keys (view (csChannels . ix channel . chanUsers) cs) - - masks = mkId <$> HashMap.keys (view (csChannels . ix channel . chanLists . ix mode) cs) - - usermasks = - [ mkId ("*!*@" <> host) - | nick <- HashMap.keys (view (csChannels . ix channel . chanUsers) cs) - , UserAndHost _ host _ <- toListOf (csUsers . ix nick) cs - ] - --- | Predicate for mode commands that can be performed without ops -isPublicChannelMode :: (Bool, Char, Text) -> Bool -isPublicChannelMode (True, 'b', param) = Text.null param -- query ban list -isPublicChannelMode (True, 'q', param) = Text.null param -- query quiet list -isPublicChannelMode _ = False - -commandNameCompletion :: Bool -> ClientState -> Maybe ClientState -commandNameCompletion isReversed st = - do guard (cursorPos == n) - clientTextBox (wordComplete plainWordCompleteMode isReversed [] possibilities) st - where - n = length white + length leadingPart - (cursorPos, line) = clientLine st - (white, leadingPart) = takeWhile (' ' /=) <$> span (' '==) line - possibilities = Text.cons '/' <$> commandNames - commandNames = keys commands - ++ keys (view (clientConfig . configMacros) st) - --- | Complete the nickname at the current cursor position using the --- userlist for the currently focused channel (if any) -nickTabCompletion :: Bool {- ^ reversed -} -> ClientState -> IO CommandResult -nickTabCompletion isReversed st = - simpleTabCompletion mode hint completions isReversed st - where - hint = activeNicks st - completions = currentCompletionList st - mode = currentNickCompletionMode st - -cmdExtension :: ClientCommand (String, String) -cmdExtension st (name,command) = - do res <- clientCommandExtension (Text.pack name) (Text.pack command) st - case res of - Nothing -> commandFailureMsg "unknown extension" st - Just st' -> commandSuccess st' - --- | Implementation of @/exec@ command. -cmdExec :: ClientCommand String -cmdExec st rest = - do now <- getZonedTime - case parseExecCmd rest of - Left es -> failure now es - Right ec -> - case buildTransmitter now ec of - Left es -> failure now es - Right tx -> - do res <- runExecCmd ec - case res of - Left es -> failure now es - Right msgs -> tx (map Text.pack msgs) - - where - buildTransmitter now ec = - case (Text.pack <$> view execOutputNetwork ec, - Text.pack <$> view execOutputChannel ec) of - - (Unspecified, Unspecified) -> Right (sendToClient now) - - (Specified network, Specified channel) -> - case preview (clientConnection network) st of - Nothing -> Left ["Unknown network"] - Just cs -> Right (sendToChannel cs channel) - - (_ , Specified channel) -> - case currentNetworkState of - Nothing -> Left ["No current network"] - Just cs -> Right (sendToChannel cs channel) - - (Specified network, _) -> - case preview (clientConnection network) st of - Nothing -> Left ["Unknown network"] - Just cs -> Right (sendToNetwork now cs) - - (_, Current) -> - case currentNetworkState of - Nothing -> Left ["No current network"] - Just cs -> - case view clientFocus st of - ChannelFocus _ channel -> Right (sendToChannel cs (idText channel)) - _ -> Left ["No current channel"] - - (Current, _) -> - case currentNetworkState of - Nothing -> Left ["No current network"] - Just cs -> Right (sendToNetwork now cs) - - sendToClient now msgs = commandSuccess $! foldl' (recordSuccess now) st msgs - - sendToNetwork now cs msgs = - commandSuccess =<< - foldM (\st1 msg -> - case parseRawIrcMsg msg of - Nothing -> - return $! recordError now "" ("Bad raw message: " <> msg) st1 - Just raw -> - do sendMsg cs raw - return st1) st msgs - - sendToChannel cs channel msgs = - commandSuccess =<< - foldM (\st1 msg -> - do sendMsg cs (ircPrivmsg channel msg) - chatCommand' - (\src tgt -> Privmsg src tgt msg) - channel - cs st1) st (filter (not . Text.null) msgs) - - currentNetworkState = - do network <- views clientFocus focusNetwork st - preview (clientConnection network) st - - failure now es = - commandFailure $! foldl' (flip (recordError now "")) st (map Text.pack es) - -recordSuccess :: ZonedTime -> ClientState -> Text -> ClientState -recordSuccess now ste m = - recordNetworkMessage ClientMessage - { _msgTime = now - , _msgBody = NormalBody m - , _msgNetwork = "" - } ste - - -cmdUrl :: ClientCommand (Maybe Int) -cmdUrl st arg = - case view (clientConfig . configUrlOpener) st of - Nothing -> commandFailureMsg "url-opener not configured" st - Just opener -> doUrlOpen opener (maybe 0 (subtract 1) arg) - where - focus = view clientFocus st - - urls = toListOf ( clientWindows . ix focus . winMessages . each . wlText - . folding urlMatches) st - - doUrlOpen opener n = - case preview (ix n) urls of - Just url -> openUrl opener (Text.unpack url) st - Nothing -> commandFailureMsg "bad url number" st - -openUrl :: FilePath -> String -> ClientState -> IO CommandResult -openUrl opener url st = - do res <- try (callProcess opener [url]) - case res of - Left e -> commandFailureMsg (Text.pack (displayException (e :: IOError))) st - Right{} -> commandSuccess st - --- | Implementation of @/grep@ -cmdGrep :: ClientCommand String -cmdGrep st str - | null str = commandSuccess (set clientRegex Nothing st) - | otherwise = - case buildMatcher str of - Nothing -> commandFailureMsg "bad grep" st - Just r -> commandSuccess (set clientRegex (Just r) st) - -cmdOper :: NetworkCommand (String, String) -cmdOper cs st (user, pass) = - do sendMsg cs (ircOper (Text.pack user) (Text.pack pass)) - commandSuccess st - -cmdCert :: NetworkCommand () -cmdCert _ st _ = commandSuccess (changeSubfocus FocusCert st) +import Client.Message +import Client.State +import Client.State.Extensions +import Client.State.Focus +import Client.State.Network +import Client.State.Window +import Control.Applicative +import Control.Exception (displayException, try) +import Control.Lens +import Control.Monad +import Data.Foldable +import Data.Text (Text) +import qualified Data.Text as Text +import Data.Time (ZonedTime, getZonedTime) +import Irc.Commands +import Irc.Identifier +import Irc.RawIrcMsg +import Irc.Message +import RtsStats (getStats) +import System.Process + +import Client.Commands.Channel (channelCommands) +import Client.Commands.Chat (chatCommands, chatCommand', executeChat) +import Client.Commands.Connection (connectionCommands) +import Client.Commands.DCC (dccCommands) +import Client.Commands.Operator (operatorCommands) +import Client.Commands.Queries (queryCommands) +import Client.Commands.Toggles (togglesCommands) +import Client.Commands.Window (windowCommands) +import Client.Commands.ZNC (zncCommands) +import Client.Commands.TabCompletion +import Client.Commands.Types + +-- | Interpret the given chat message or command. Leading @/@ indicates a +-- command. Otherwise if a channel or user query is focused a chat message will +-- be sent. Leading spaces before the @/@ are ignored when checking for +-- commands. +execute :: + String {- ^ chat or command -} -> + ClientState {- ^ client state -} -> + IO CommandResult {- ^ command result -} +execute str st = + let st' = set clientErrorMsg Nothing st in + case dropWhile (' '==) str of + [] -> commandFailure st + '/':command -> executeUserCommand Nothing command st' + _ -> executeChat str st' + +-- | Execute command provided by user, resolve aliases if necessary. +-- +-- The last disconnection time is stored in text form and is available +-- for substitutions in macros. It is only provided when running startup +-- commands during a reconnect event. +executeUserCommand :: + Maybe Text {- ^ disconnection time -} -> + String {- ^ command -} -> + ClientState {- ^ client state -} -> + IO CommandResult {- ^ command result -} +executeUserCommand discoTime command st = do + let key = Text.takeWhile (/=' ') (Text.pack command) + rest = dropWhile (==' ') (dropWhile (/=' ') command) + + case views (clientConfig . configMacros) (recognize key) st of + Exact (Macro (MacroSpec spec) cmdExs) -> + case doExpansion spec cmdExs rest of + Nothing -> commandFailureMsg "macro expansions failed" st + Just cmds -> process cmds st + _ -> executeCommand Nothing command st + where + doExpansion spec cmdExs rest = + do args <- parse st spec rest + traverse (resolveMacro (map Text.pack args)) cmdExs + + resolveMacro args = resolveMacroExpansions (commandExpansion discoTime st) (expandInt args) + + expandInt :: [a] -> Integer -> Maybe a + expandInt args i = preview (ix (fromInteger i)) args + + + + process [] st0 = commandSuccess st0 + process (c:cs) st0 = + do res <- executeCommand Nothing (Text.unpack c) st0 + case res of + CommandSuccess st1 -> process cs st1 + CommandFailure st1 -> process cs st1 -- ? + CommandQuit st1 -> return (CommandQuit st1) + +-- | Compute the replacement value for the given expansion variable. +commandExpansion :: + Maybe Text {- ^ disconnect time -} -> + ClientState {- ^ client state -} -> + Text {- ^ expansion variable -} -> + Maybe Text {- ^ expansion value -} +commandExpansion discoTime st v = + case v of + "network" -> views clientFocus focusNetwork st + "channel" -> previews (clientFocus . _ChannelFocus . _2) idText st + "nick" -> do net <- views clientFocus focusNetwork st + cs <- preview (clientConnection net) st + return (views csNick idText cs) + "disconnect" -> discoTime + _ -> Nothing + + +-- | Respond to the TAB key being pressed. This can dispatch to a command +-- specific completion mode when relevant. Otherwise this will complete +-- input based on the users of the channel related to the current buffer. +tabCompletion :: + Bool {- ^ reversed -} -> + ClientState {- ^ client state -} -> + IO CommandResult {- ^ command result -} +tabCompletion isReversed st = + case dropWhile (' ' ==) $ snd $ clientLine st of + '/':command -> executeCommand (Just isReversed) command st + _ -> nickTabCompletion isReversed st + + +-- | Parse and execute the given command. When the first argument is Nothing +-- the command is executed, otherwise the first argument is the cursor +-- position for tab-completion +executeCommand :: + Maybe Bool {- ^ tab-completion direction -} -> + String {- ^ command -} -> + ClientState {- ^ client state -} -> + IO CommandResult {- ^ command result -} + +executeCommand (Just isReversed) _ st + | Just st' <- commandNameCompletion isReversed st = commandSuccess st' + +executeCommand tabCompleteReversed str st = + let (cmd, rest) = break (==' ') str + cmdTxt = Text.toLower (Text.pack cmd) + + finish spec exec tab = + case tabCompleteReversed of + Just isReversed -> tab isReversed st rest + Nothing -> + case parse st spec rest of + Nothing -> commandFailureMsg "bad command arguments" st + Just arg -> exec st arg + in + case recognize cmdTxt commands of + + Exact Command{cmdImplementation=impl, cmdArgumentSpec=argSpec} -> + case impl of + ClientCommand exec tab -> + finish argSpec exec tab + + NetworkCommand exec tab + | Just network <- views clientFocus focusNetwork st + , Just cs <- preview (clientConnection network) st -> + finish argSpec (exec cs) (\x -> tab x cs) + | otherwise -> commandFailureMsg "command requires focused network" st + + ChannelCommand exec tab + | ChannelFocus network channelId <- view clientFocus st + , Just cs <- preview (clientConnection network) st + , isChannelIdentifier cs channelId -> + finish argSpec (exec channelId cs) (\x -> tab x channelId cs) + | otherwise -> commandFailureMsg "command requires focused channel" st + + ChatCommand exec tab + | ChannelFocus network channelId <- view clientFocus st + , Just cs <- preview (clientConnection network) st -> + finish argSpec (exec channelId cs) (\x -> tab x channelId cs) + | otherwise -> commandFailureMsg "command requires focused chat window" st + + _ -> case tabCompleteReversed of + Just isReversed -> nickTabCompletion isReversed st + Nothing -> commandFailureMsg "unknown command" st + + +-- | Expands each alias to have its own copy of the command callbacks +expandAliases :: [Command] -> [(Text,Command)] +expandAliases xs = + [ (name, cmd) | cmd <- xs, name <- toList (cmdNames cmd) ] + + +-- | Map of built-in client commands to their implementations, tab completion +-- logic, and argument structures. +commands :: Recognizer Command +commands = fromCommands (expandAliases (concatMap cmdSectionCmds commandsList)) + + +-- | Raw list of commands in the order used for @/help@ +commandsList :: [CommandSection] +commandsList = + + ------------------------------------------------------------------------ + [ CommandSection "Client commands" + ------------------------------------------------------------------------ + + [ Command + (pure "exit") + (pure ()) + "Exit the client immediately.\n" + $ ClientCommand cmdExit noClientTab + + , Command + (pure "reload") + (optionalArg (simpleToken "[filename]")) + "Reload the client configuration file.\n\ + \\n\ + \If \^Bfilename\^B is provided it will be used to reload.\n\ + \Otherwise the previously loaded configuration file will be reloaded.\n" + $ ClientCommand cmdReload tabReload + + , Command + (pure "extension") + (liftA2 (,) (simpleToken "extension") (remainingArg "arguments")) + "Calls the process_command callback of the given extension.\n\ + \\n\ + \\^Bextension\^B should be the name of the loaded extension.\n" + $ ClientCommand cmdExtension simpleClientTab + + , Command + (pure "palette") + (pure ()) + "Show the current palette settings and a color chart to help pick new colors.\n" + $ ClientCommand cmdPalette noClientTab + + , Command + (pure "digraphs") + (pure ()) + "\^BDescription:\^B\n\ + \\n\ + \ Show the table of digraphs. A digraph is a pair of characters\n\ + \ can be used together to represent an uncommon character. Type\n\ + \ the two-character digraph corresponding to the desired output\n\ + \ character and then press M-k (default binding).\n\ + \\n\ + \ Note that the digraphs list is searchable with /grep.\n\ + \\n\ + \\^BSee also:\^B grep\n" + $ ClientCommand cmdDigraphs noClientTab + + , Command + (pure "keymap") + (pure ()) + "Show the key binding map.\n\ + \\n\ + \Key bindings can be changed in configuration file. See `glirc --config-format`.\n" + $ ClientCommand cmdKeyMap noClientTab + + , Command + (pure "rtsstats") + (pure ()) + "Show the GHC RTS statistics.\n" + $ ClientCommand cmdRtsStats noClientTab + + , Command + (pure "exec") + (remainingArg "arguments") + "Execute a command synchnonously sending the to a configuration destination.\n\ + \\n\ + \\^Barguments\^B: [-n[network]] [-c[channel]] [-i input] command [arguments...]\n\ + \\n\ + \When \^Binput\^B is specified it is sent to the stdin.\n\ + \\n\ + \When neither \^Bnetwork\^B nor \^Bchannel\^B are specified output goes to client window (*).\n\ + \When \^Bnetwork\^B is specified output is sent as raw IRC traffic to the network.\n\ + \When \^Bchannel\^B is specified output is sent as chat to the given channel on the current network.\n\ + \When \^Bnetwork\^B and \^Bchannel\^B are specified output is sent as chat to the given channel on the given network.\n\ + \\n\ + \\^Barguments\^B is divided on spaces into words before being processed\ + \ by getopt. Use Haskell string literal syntax to create arguments with\ + \ escaped characters and spaces inside.\n\ + \\n" + $ ClientCommand cmdExec simpleClientTab + + , Command + (pure "url") + optionalNumberArg + "Open a URL seen in chat.\n\ + \\n\ + \The URL is opened using the executable configured under \^Burl-opener\^B.\n\ + \\n\ + \When this command is active in the textbox, chat messages are filtered to\ + \ only show ones with URLs.\n\ + \\n\ + \When \^Bnumber\^B is omitted it defaults to \^B1\^B. The number selects the\ + \ URL to open counting back from the most recent.\n" + $ ClientCommand cmdUrl noClientTab + + , Command + (pure "help") + (optionalArg (simpleToken "[command]")) + "Show command documentation.\n\ + \\n\ + \When \^Bcommand\^B is omitted a list of all commands is displayed.\n\ + \When \^Bcommand\^B is specified detailed help for that command is shown.\n" + $ ClientCommand cmdHelp tabHelp + + ------------------------------------------------------------------------ + ], + + togglesCommands, connectionCommands, windowCommands, chatCommands, + queryCommands, channelCommands, zncCommands, operatorCommands, + dccCommands ] + +-- | Implementation of @/exit@ command. +cmdExit :: ClientCommand () +cmdExit st _ = return (CommandQuit st) + +-- | Implementation of @/palette@ command. Set subfocus to Palette. +cmdPalette :: ClientCommand () +cmdPalette st _ = commandSuccess (changeSubfocus FocusPalette st) + +-- | Implementation of @/digraphs@ command. Set subfocus to Digraphs. +cmdDigraphs :: ClientCommand () +cmdDigraphs st _ = commandSuccess (changeSubfocus FocusDigraphs st) + +-- | Implementation of @/keymap@ command. Set subfocus to Keymap. +cmdKeyMap :: ClientCommand () +cmdKeyMap st _ = commandSuccess (changeSubfocus FocusKeyMap st) + +-- | Implementation of @/rtsstats@ command. Set subfocus to RtsStats. +-- Update cached rts stats in client state. +cmdRtsStats :: ClientCommand () +cmdRtsStats st _ = + do mb <- getStats + case mb of + Nothing -> commandFailureMsg "RTS statistics not available. (Use +RTS -T)" st + Just{} -> commandSuccess $ set clientRtsStats mb + $ changeSubfocus FocusRtsStats st + +-- | Implementation of @/help@ command. Set subfocus to Help. +cmdHelp :: ClientCommand (Maybe String) +cmdHelp st mb = commandSuccess (changeSubfocus focus st) + where + focus = FocusHelp (fmap Text.pack mb) + +tabHelp :: Bool -> ClientCommand String +tabHelp isReversed st _ = + simpleTabCompletion plainWordCompleteMode [] commandNames isReversed st + where + commandNames = fst <$> expandAliases (concatMap cmdSectionCmds commandsList) + +-- | Implementation of @/reload@ +-- +-- Attempt to reload the configuration file +cmdReload :: ClientCommand (Maybe String) +cmdReload st mbPath = + do let path = mbPath <|> Just (view clientConfigPath st) + res <- loadConfiguration path + case res of + Left e -> commandFailureMsg (describeProblem e) st + Right (path',cfg) -> + do st1 <- clientStartExtensions + $ set clientConfig cfg + $ set clientConfigPath path' st + commandSuccess st1 + + where + describeProblem err = + Text.pack $ + case err of + ConfigurationReadFailed e -> "Failed to open configuration: " ++ e + ConfigurationParseFailed _ e -> "Failed to parse configuration: " ++ e + ConfigurationMalformed _ e -> "Configuration malformed: " ++ e + +-- | Support file name tab completion when providing an alternative +-- configuration file. +-- +-- /NOT IMPLEMENTED/ +tabReload :: Bool {- ^ reversed -} -> ClientCommand String +tabReload _ st _ = commandFailure st + +commandNameCompletion :: Bool -> ClientState -> Maybe ClientState +commandNameCompletion isReversed st = + do guard (cursorPos == n) + clientTextBox (wordComplete plainWordCompleteMode isReversed [] possibilities) st + where + n = length white + length leadingPart + (cursorPos, line) = clientLine st + (white, leadingPart) = takeWhile (' ' /=) <$> span (' '==) line + possibilities = Text.cons '/' <$> commandNames + commandNames = keys commands + ++ keys (view (clientConfig . configMacros) st) + +cmdExtension :: ClientCommand (String, String) +cmdExtension st (name,command) = + do res <- clientCommandExtension (Text.pack name) (Text.pack command) st + case res of + Nothing -> commandFailureMsg "unknown extension" st + Just st' -> commandSuccess st' + +-- | Implementation of @/exec@ command. +cmdExec :: ClientCommand String +cmdExec st rest = + do now <- getZonedTime + case parseExecCmd rest of + Left es -> failure now es + Right ec -> + case buildTransmitter now ec of + Left es -> failure now es + Right tx -> + do res <- runExecCmd ec + case res of + Left es -> failure now es + Right msgs -> tx (map Text.pack msgs) + + where + buildTransmitter now ec = + case (Text.pack <$> view execOutputNetwork ec, + Text.pack <$> view execOutputChannel ec) of + + (Unspecified, Unspecified) -> Right (sendToClient now) + + (Specified network, Specified channel) -> + case preview (clientConnection network) st of + Nothing -> Left ["Unknown network"] + Just cs -> Right (sendToChannel cs channel) + + (_ , Specified channel) -> + case currentNetworkState of + Nothing -> Left ["No current network"] + Just cs -> Right (sendToChannel cs channel) + + (Specified network, _) -> + case preview (clientConnection network) st of + Nothing -> Left ["Unknown network"] + Just cs -> Right (sendToNetwork now cs) + + (_, Current) -> + case currentNetworkState of + Nothing -> Left ["No current network"] + Just cs -> + case view clientFocus st of + ChannelFocus _ channel -> Right (sendToChannel cs (idText channel)) + _ -> Left ["No current channel"] + + (Current, _) -> + case currentNetworkState of + Nothing -> Left ["No current network"] + Just cs -> Right (sendToNetwork now cs) + + sendToClient now msgs = commandSuccess $! foldl' (recordSuccess now) st msgs + + sendToNetwork now cs msgs = + commandSuccess =<< + foldM (\st1 msg -> + case parseRawIrcMsg msg of + Nothing -> + return $! recordError now "" ("Bad raw message: " <> msg) st1 + Just raw -> + do sendMsg cs raw + return st1) st msgs + + sendToChannel cs channel msgs = + commandSuccess =<< + foldM (\st1 msg -> + do sendMsg cs (ircPrivmsg channel msg) + chatCommand' + (\src tgt -> Privmsg src tgt msg) + channel + cs st1) st (filter (not . Text.null) msgs) + + currentNetworkState = + do network <- views clientFocus focusNetwork st + preview (clientConnection network) st + + failure now es = + commandFailure $! foldl' (flip (recordError now "")) st (map Text.pack es) + +recordSuccess :: ZonedTime -> ClientState -> Text -> ClientState +recordSuccess now ste m = + recordNetworkMessage ClientMessage + { _msgTime = now + , _msgBody = NormalBody m + , _msgNetwork = "" + } ste + + +cmdUrl :: ClientCommand (Maybe Int) +cmdUrl st arg = + case view (clientConfig . configUrlOpener) st of + Nothing -> commandFailureMsg "url-opener not configured" st + Just opener -> doUrlOpen opener (maybe 0 (subtract 1) arg) + where + focus = view clientFocus st + + urls = toListOf ( clientWindows . ix focus . winMessages . each . wlText + . folding urlMatches) st + + doUrlOpen opener n = + case preview (ix n) urls of + Just url -> openUrl opener (Text.unpack url) st + Nothing -> commandFailureMsg "bad url number" st + +openUrl :: FilePath -> String -> ClientState -> IO CommandResult +openUrl opener url st = + do res <- try (callProcess opener [url]) + case res of + Left e -> commandFailureMsg (Text.pack (displayException (e :: IOError))) st + Right{} -> commandSuccess st diff --git a/src/Client/Commands/Channel.hs b/src/Client/Commands/Channel.hs new file mode 100644 --- /dev/null +++ b/src/Client/Commands/Channel.hs @@ -0,0 +1,326 @@ +{-# Language OverloadedStrings #-} +{-| +Module : Client.Commands.Channel +Description : Channel management command implementations +Copyright : (c) Eric Mertens, 2016-2020 +License : ISC +Maintainer : emertens@gmail.com +-} + +module Client.Commands.Channel (channelCommands) where + +import Client.Commands.Arguments.Spec +import Client.Commands.TabCompletion +import Client.Commands.Types +import Client.Commands.WordCompletion +import Client.State +import Client.State.Channel +import Client.State.Focus +import Client.State.Network +import Client.UserHost +import Control.Applicative +import Control.Lens +import Control.Monad +import Data.Foldable (traverse_) +import Data.List.Split (chunksOf) +import Data.Maybe (fromMaybe) +import Data.Text (Text) +import qualified Client.State.EditBox as Edit +import qualified Data.HashMap.Strict as HashMap +import qualified Data.Text as Text +import Irc.Commands +import Irc.Modes +import Irc.UserInfo +import Irc.Identifier +import LensUtils (setStrict) + +channelCommands :: CommandSection +channelCommands = CommandSection "IRC channel management" + + [ Command + (pure "mode") + (fromMaybe [] <$> optionalArg (extensionArg "[modes]" modeParamArgs)) + "Sets IRC modes.\n\ + \\n\ + \Examples:\n\ + \Setting a ban: /mode +b *!*@hostname\n\ + \Removing a quiet: /mode -q *!*@hostname\n\ + \Voicing two users: /mode +vv user1 user2\n\ + \Demoting an op to voice: /mode +v-o user1 user1\n\ + \\n\ + \When executed in a network window, mode changes are applied to your user.\n\ + \When executed in a channel window, mode changes are applied to the channel.\n\ + \\n\ + \This command has parameter sensitive tab-completion.\n\ + \\n\ + \See also: /masks /channelinfo\n" + $ NetworkCommand cmdMode tabMode + + , Command + (pure "masks") + (simpleToken "mode") + "Show mask lists for current channel.\n\ + \\n\ + \Common \^Bmode\^B values:\n\ + \\^Bb\^B: bans\n\ + \\^Bq\^B: quiets\n\ + \\^BI\^B: invite exemptions (op view only)\n\ + \\^Be\^B: ban exemption (op view only)s\n\ + \\n\ + \To populate the mask lists for the first time use: /mode \^Bmode\^B\n\ + \\n\ + \See also: /mode\n" + $ ChannelCommand cmdMasks noChannelTab + + , Command + (pure "invite") + (simpleToken "nick") + "Invite a user to the current channel.\n" + $ ChannelCommand cmdInvite simpleChannelTab + + , Command + (pure "topic") + (remainingArg "message") + "Set the topic on the current channel.\n\ + \\n\ + \Tab-completion with no \^Bmessage\^B specified will load the current topic for editing.\n" + $ ChannelCommand cmdTopic tabTopic + + , Command + (pure "kick") + (liftA2 (,) (simpleToken "nick") (remainingArg "reason")) + "Kick a user from the current channel.\n\ + \\n\ + \See also: /kickban /remove\n" + $ ChannelCommand cmdKick simpleChannelTab + + , Command + (pure "kickban") + (liftA2 (,) (simpleToken "nick") (remainingArg "reason")) + "Ban and kick a user from the current channel.\n\ + \\n\ + \Users are banned by hostname match.\n\ + \See also: /kick /remove\n" + $ ChannelCommand cmdKickBan simpleChannelTab + + , Command + (pure "remove") + (liftA2 (,) (simpleToken "nick") (remainingArg "reason")) + "Remove a user from the current channel.\n\ + \\n\ + \Remove works like /kick except it results in a PART.\n\ + \See also: /kick /kickban\n" + $ ChannelCommand cmdRemove simpleChannelTab + + ] + +cmdRemove :: ChannelCommand (String, String) +cmdRemove channelId cs st (who,reason) = + do let msg = Text.pack reason + cmd = ircRemove channelId (Text.pack who) msg + cs' <- sendModeration channelId [cmd] cs + commandSuccessUpdateCS cs' st + +cmdKick :: ChannelCommand (String, String) +cmdKick channelId cs st (who,reason) = + do let msg = Text.pack reason + cmd = ircKick channelId (Text.pack who) msg + cs' <- sendModeration channelId [cmd] cs + commandSuccessUpdateCS cs' st + + +cmdKickBan :: ChannelCommand (String, String) +cmdKickBan channelId cs st (who,reason) = + do let msg = Text.pack reason + + whoTxt = Text.pack who + + mask = renderUserInfo (computeBanUserInfo (mkId whoTxt) cs) + cmds = [ ircMode channelId ["b", mask] + , ircKick channelId whoTxt msg + ] + cs' <- sendModeration channelId cmds cs + commandSuccessUpdateCS cs' st + +cmdInvite :: ChannelCommand String +cmdInvite channelId cs st nick = + do let freeTarget = has (csChannels . ix channelId . chanModes . ix 'g') cs + cmd = ircInvite (Text.pack nick) channelId + cs' <- if freeTarget + then cs <$ sendMsg cs cmd + else sendModeration channelId [cmd] cs + commandSuccessUpdateCS cs' st + +commandSuccessUpdateCS :: NetworkState -> ClientState -> IO CommandResult +commandSuccessUpdateCS cs st = + do let network = view csNetwork cs + commandSuccess + $ setStrict (clientConnection network) cs st + +cmdMasks :: ChannelCommand String +cmdMasks channel cs st rest = + case rest of + [mode] | mode `elem` view (csModeTypes . modesLists) cs -> + + do let connecting = has (csPingStatus . _PingConnecting) cs + listLoaded = has (csChannels . ix channel . chanLists . ix mode) cs + unless (connecting || listLoaded) + (sendMsg cs (ircMode channel [Text.singleton mode])) + + commandSuccess (changeSubfocus (FocusMasks mode) st) + + _ -> commandFailureMsg "unknown mask mode" st + +computeBanUserInfo :: Identifier -> NetworkState -> UserInfo +computeBanUserInfo who cs = + case view (csUser who) cs of + Nothing -> UserInfo who "*" "*" + Just (UserAndHost _ host _) -> UserInfo "*" "*" host + +cmdTopic :: ChannelCommand String +cmdTopic channelId cs st rest = + do sendTopic channelId (Text.pack rest) cs + commandSuccess st + +tabTopic :: + Bool {- ^ reversed -} -> + ChannelCommand String +tabTopic _ channelId cs st rest + + | all (==' ') rest + , Just topic <- preview (csChannels . ix channelId . chanTopic) cs = + do let textBox = set Edit.line (Edit.endLine $ "/topic " ++ Text.unpack topic) + commandSuccess (over clientTextBox textBox st) + + | otherwise = commandFailure st + +cmdMode :: NetworkCommand [String] +cmdMode cs st xs = modeCommand (Text.pack <$> xs) cs st + +modeCommand :: + [Text] {- mode parameters -} -> + NetworkState -> + ClientState -> + IO CommandResult +modeCommand modes cs st = + case view clientFocus st of + + NetworkFocus _ -> + do sendMsg cs (ircMode (view csNick cs) modes) + commandSuccess st + + ChannelFocus _ chan -> + case modes of + [] -> success False [[]] + flags:params -> + case splitModes (view csModeTypes cs) flags params of + Nothing -> commandFailureMsg "failed to parse modes" st + Just parsedModes -> + success needOp (unsplitModes <$> chunksOf (view csModeCount cs) parsedModes') + where + parsedModes' + | useChanServ chan cs = filter (not . isOpMe) parsedModes + | otherwise = parsedModes + + needOp = not (all isPublicChannelMode parsedModes) + where + isOpMe (True, 'o', param) = mkId param == view csNick cs + isOpMe _ = False + + success needOp argss = + do let cmds = ircMode chan <$> argss + cs' <- if needOp + then sendModeration chan cmds cs + else cs <$ traverse_ (sendMsg cs) cmds + commandSuccessUpdateCS cs' st + + _ -> commandFailure st + +tabMode :: Bool -> NetworkCommand String +tabMode isReversed cs st rest = + case view clientFocus st of + + ChannelFocus _ channel + | flags:params <- Text.words (Text.pack rest) + , Just parsedModes <- splitModes (view csModeTypes cs) flags params + , let parsedModesWithParams = + [ (pol,mode) | (pol,mode,arg) <- parsedModes, not (Text.null arg) ] + , (pol,mode):_ <- drop (paramIndex-3) parsedModesWithParams + , let (hint, completions) = computeModeCompletion pol mode channel cs st + -> simpleTabCompletion plainWordCompleteMode hint completions isReversed st + + _ -> commandFailure st + + where + paramIndex = length $ words $ uncurry take $ clientLine st + +modeParamArgs :: ClientState -> String -> Maybe (Args ClientState [String]) +modeParamArgs st str = + case view clientFocus st of + Unfocused -> Nothing + NetworkFocus _ -> Just (pure [str]) + ChannelFocus net _ -> + + -- determine current mode types + do cs <- preview (clientConnection net) st + let types = view csModeTypes cs + + -- parse the list of modes being set + flags <- splitModes types (Text.pack str) [] + + -- generate the argument specification + let (req,opt) = foldr (countFlags types) ([],[]) flags + return ((str:) <$> tokenList req (map (++"?") opt)) + +-- | This function computes the list of required and optional parameters +-- corresponding to the flags that have been entered. +countFlags :: + ModeTypes {- ^ network's mode behaviors -} -> + (Bool, Char, Text) {- ^ polarity mode-letter unused-parameter -} -> + ([String],[String]) {- ^ required-names optional-names -} -> + ([String],[String]) {- ^ required-names optional-names -} +countFlags types (pol, flag, _) + | flag `elem` view modesLists types = addOpt + | pol && flag `elem` view modesSetArg types = addReq + | flag `elem` view modesAlwaysArg types = addReq + | elemOf (modesPrefixModes . folded . _1) flag types = addReq + | otherwise = id + where + addReq (req,opt) = ((flag:" param"):req,opt) + addOpt ([] ,opt) = ([], (flag:" param"):opt) + addOpt (req,opt) = ((flag:" param"):req,opt) + + +-- | Use the *!*@host masks of users for channel lists when setting list modes +-- +-- Use the channel's mask list for removing modes +-- +-- Use the nick list otherwise +computeModeCompletion :: + Bool {- ^ mode polarity -} -> + Char {- ^ mode -} -> + Identifier {- ^ channel -} -> + NetworkState -> + ClientState -> + ([Identifier],[Identifier]) {- ^ (hint, complete) -} +computeModeCompletion pol mode channel cs st + | mode `elem` view modesLists modeSettings = + if pol then ([],usermasks) else ([],masks) + | otherwise = (activeNicks st, nicks) + where + modeSettings = view csModeTypes cs + nicks = HashMap.keys (view (csChannels . ix channel . chanUsers) cs) + + masks = mkId <$> HashMap.keys (view (csChannels . ix channel . chanLists . ix mode) cs) + + usermasks = + [ mkId ("*!*@" <> host) + | nick <- HashMap.keys (view (csChannels . ix channel . chanUsers) cs) + , UserAndHost _ host _ <- toListOf (csUsers . ix nick) cs + ] + +-- | Predicate for mode commands that can be performed without ops +isPublicChannelMode :: (Bool, Char, Text) -> Bool +isPublicChannelMode (True, 'b', param) = Text.null param -- query ban list +isPublicChannelMode (True, 'q', param) = Text.null param -- query quiet list +isPublicChannelMode _ = False diff --git a/src/Client/Commands/Chat.hs b/src/Client/Commands/Chat.hs new file mode 100644 --- /dev/null +++ b/src/Client/Commands/Chat.hs @@ -0,0 +1,522 @@ +{-# Language BangPatterns, OverloadedStrings #-} +{-| +Module : Client.Commands.Chat +Description : Common user IRC commands +Copyright : (c) Eric Mertens, 2016-2020 +License : ISC +Maintainer : emertens@gmail.com +-} + +module Client.Commands.Chat (chatCommands, chatCommand', executeChat, cmdCtcp) where + +import Client.Commands.Arguments.Spec +import Client.Commands.TabCompletion +import Client.Commands.Types +import Client.Commands.Window (parseFocus) +import Client.Message +import Client.State +import Client.State.Extensions (clientChatExtension) +import Client.State.Focus +import Client.State.Network +import Control.Applicative +import Control.Lens +import Control.Monad (when) +import Data.Char (toUpper) +import Data.Foldable +import Data.List.NonEmpty (NonEmpty((:|))) +import Data.Text (Text) +import qualified Data.Text as Text +import Data.Time +import Irc.Commands +import Irc.Identifier +import Irc.Message +import Irc.RawIrcMsg +import Irc.UserInfo + +chatCommands :: CommandSection +chatCommands = CommandSection "IRC commands" + ------------------------------------------------------------------------ + + [ Command + ("join" :| ["j"]) + (liftA2 (,) (simpleToken "channels") (optionalArg (simpleToken "[keys]"))) + "\^BParameters:\^B\n\ + \\n\ + \ channels: Comma-separated list of channels\n\ + \ keys: Comma-separated list of keys\n\ + \\n\ + \\^BDescription:\^B\n\ + \\n\ + \ Join the given channels. When keys are provided, they should\n\ + \ occur in the same order as the channels.\n\ + \\n\ + \\^BExamples:\^B\n\ + \\n\ + \ /join #friends\n\ + \ /join #secret thekey\n\ + \ /join #secret1,#secret2 key1,key2\n\ + \\n\ + \\^BSee also:\^B channel, clear, part\n" + $ NetworkCommand cmdJoin simpleNetworkTab + + , Command + (pure "part") + (remainingArg "reason") + "\^BParameters:\^B\n\ + \\n\ + \ reason: Optional message sent to channel as part reason\ + \\n\ + \\^BDescription:\^B\n\ + \\n\ + \ Part from the current channel.\n\ + \\n\ + \\^BExamples:\^B\n\ + \\n\ + \ /part\n\ + \ /part It's not me, it's you\n\ + \\n\ + \\^BSee also:\^B clear, join, quit\n" + $ ChannelCommand cmdPart simpleChannelTab + + , Command + (pure "msg") + (liftA2 (,) (simpleToken "target") (remainingArg "message")) + "\^BParameters:\^B\n\ + \\n\ + \ target: Comma-separated list of nicknames and channels\n\ + \ message: Formatted message body\n\ + \\n\ + \\^BDescription:\^B\n\ + \\n\ + \ Send a chat message to a user or a channel. On servers\n\ + \ with STATUSMSG support, the channel name can be prefixed\n\ + \ with a sigil to restrict the recipients to those with the\n\ + \ given mode.\n\ + \\n\ + \\^BExamples:\^B\n\ + \\n\ + \ /msg buddy I'm sending you a message.\n\ + \ /msg #friends This message is for the whole channel.\n\ + \ /msg him,her I'm chatting with two people.\n\ + \ /msg @#users This message is only for ops!\n\ + \\n\ + \\^BSee also:\^B notice, me, say\n" + $ NetworkCommand cmdMsg simpleNetworkTab + + , Command + (pure "me") + (remainingArg "message") + "\^BParameters:\^B\n\ + \\n\ + \ message: Body of action message\n\ + \\n\ + \\^BDescription:\^B\n\ + \\n\ + \ Sends an action message to the currently focused channel.\n\ + \ Most clients will render these messages prefixed with\n\ + \ only your nickname as though describing an action.\n\ + \\n\ + \\^BExamples:\^B\n\ + \\n\ + \ /me shrugs\n\ + \\n\ + \\^BSee also:\^B notice, msg, say\n" + $ ChatCommand cmdMe simpleChannelTab + + , Command + (pure "say") + (remainingArg "message") + "\^BParameters:\^B\n\ + \\n\ + \ message: Body of message\n\ + \\n\ + \\^BDescription:\^B\n\ + \\n\ + \ Send a message to the current chat window. This can be useful\n\ + \ for sending a chat message with a leading '/' to the current\n\ + \ chat window.\n\ + \\n\ + \\^BExamples:\^B\n\ + \\n\ + \ /say /help is the right place to start!\n\ + \\n\ + \\^BSee also:\^B notice, me, msg\n" + $ ChatCommand cmdSay simpleChannelTab + + , Command + ("query" :| ["q"]) + (liftA2 (,) (simpleToken "target") (remainingArg "message")) + "\^BParameters:\^B\n\ + \\n\ + \ target: Focus name\n\ + \ message: Optional message\n\ + \\n\ + \\^BDescription:\^B\n\ + \\n\ + \ This command switches the client focus to the given\n\ + \ target and optionally sends a message to that target.\n\ + \\n\ + \ Channel: \^_#channel\^_\n\ + \ Channel: \^_network\^_:\^_#channel\^_\n\ + \ User: \^_nick\^_\n\ + \ User: \^_network\^_:\^_nick\^_\n\ + \\n\ + \\^BExamples:\^B\n\ + \\n\ + \ /q fn:#haskell\n\ + \ /q #haskell\n\ + \ /q lambdabot @messages\n\ + \ /q irc_friend How are you?\n\ + \\n\ + \\^BSee also:\^B msg channel focus\n" + $ ClientCommand cmdQuery simpleClientTab + + , Command + (pure "notice") + (liftA2 (,) (simpleToken "target") (remainingArg "message")) + "\^BParameters:\^B\n\ + \\n\ + \ target: Comma-separated list of nicknames and channels\n\ + \ message: Formatted message body\n\ + \\n\ + \\^BDescription:\^B\n\ + \\n\ + \ Send a chat notice to a user or a channel. On servers\n\ + \ with STATUSMSG support, the channel name can be prefixed\n\ + \ with a sigil to restrict the recipients to those with the\n\ + \ given mode. Notice messages were originally intended to be\n\ + \ used by bots. Different clients will render these in different\n\ + \ ways.\n\ + \\n\ + \\^BExamples:\^B\n\ + \\n\ + \ /notice buddy I'm sending you a message.\n\ + \ /notice #friends This message is for the whole channel.\n\ + \ /notice him,her I'm chatting with two people.\n\ + \ /notice @#users This message is only for ops!\n\ + \\n\ + \\^BSee also:\^B me, msg, say\n" + $ NetworkCommand cmdNotice simpleNetworkTab + + , Command + (pure "ctcp") + (liftA3 (,,) (simpleToken "target") (simpleToken "command") (remainingArg "arguments")) + "\^BParameters:\^B\n\ + \\n\ + \ target: Comma-separated list of nicknames and channels\n\ + \ command: CTCP command name\n\ + \ arguments: CTCP command arguments\n\ + \\n\ + \\^BDescription:\^B\n\ + \\n\ + \ Client-to-client protocol (CTCP) commands can be used\n\ + \ to query information from another user's client application\n\ + \ directly. Common CTCP commands include: ACTION, PING, VERSION,\n\ + \ USERINFO, CLIENTINFO, and TIME. glirc does not automatically\n\ + \ respond to CTCP commands.\n\ + \\n\ + \\^BExamples:\^B\n\ + \\n\ + \ /ctcp myfriend VERSION\n\ + \ /ctcp myfriend CLIENTINFO\n" + $ NetworkCommand cmdCtcp simpleNetworkTab + + , Command + (pure "nick") + (simpleToken "nick") + "\^BParameters:\^B\n\ + \\n\ + \ nick: New nickname\n\ + \\n\ + \\^BDescription:\^B\n\ + \\n\ + \ Change your nickname on the currently focused server.\n\ + \\n\ + \\^BExamples:\^B\n\ + \\n\ + \ /nick guest123\n\ + \ /nick better_nick\n" + $ NetworkCommand cmdNick simpleNetworkTab + + , Command + (pure "away") + (remainingArg "message") + "\^BParameters:\^B\n\ + \\n\ + \ message: Optional away message\n\ + \\n\ + \\^BDescription:\^B\n\ + \\n\ + \ Change your nickname on the currently focused server.\n\ + \ Omit the message parameter to clear your away status.\n\ + \ The away message is only used by the server to update\n\ + \ status in /whois and to provide automated responses.\n\ + \ It is not used by this client directly.\n\ + \\n\ + \\^BExamples:\^B\n\ + \\n\ + \ /away\n\ + \ /away Out getting some sun\n" + $ NetworkCommand cmdAway simpleNetworkTab + + , Command + ("users" :| ["names"]) + (pure ()) + "\^BDescription:\^B\n\ + \\n\ + \ Show the user list for the current channel.\n\ + \ Detailed view (default key F2) shows full hostmask.\n\ + \ Hostmasks can be populated with /who #channel.\n\ + \ Press ESC to exit the userlist.\n\ + \\n\ + \\^BSee also:\^B channelinfo, masks\n" + $ ChannelCommand cmdUsers noChannelTab + + , Command + (pure "channelinfo") + (pure ()) + "\^BDescription:\^B\n\ + \\n\ + \ Show information about the current channel.\n\ + \ Press ESC to exit the channel info window.\n\ + \\n\ + \ Information includes topic, creation time, URL, and modes.\n\ + \\n\ + \\^BSee also:\^B masks, mode, topic, users\n" + $ ChannelCommand cmdChannelInfo noChannelTab + + , Command + (pure "knock") + (liftA2 (,) (simpleToken "channel") (remainingArg "message")) + "Request entry to an invite-only channel.\n" + $ NetworkCommand cmdKnock simpleNetworkTab + + , Command + (pure "quote") + (remainingArg "raw IRC command") + "Send a raw IRC command.\n" + $ NetworkCommand cmdQuote simpleNetworkTab + + , Command + (pure "monitor") + (extensionArg "[+-CLS]" monitorArgs) + "\^BSubcommands:\^B\n\ + \\n\ + \ /monitor + target[,target2]* - Add nicknames to monitor list\n\ + \ /monitor - target[,target2]* - Remove nicknames to monitor list\n\ + \ /monitor C - Clear monitor list\n\ + \ /monitor L - Show monitor list\n\ + \ /monitor S - Show status of nicknames on monitor list\n\ + \\n\ + \\^BDescription:\^B\n\ + \\n\ + \ Monitor is a protocol for getting server-side notifications\n\ + \ when users become online/offline.\n" + $ NetworkCommand cmdMonitor simpleNetworkTab + + ] + +monitorArgs :: ClientState -> String -> Maybe (Args ClientState [String]) +monitorArgs _ str = + case toUpper <$> str of + "+" -> Just (wrap '+' (simpleToken "target[,target2]*")) + "-" -> Just (wrap '-' (simpleToken "target[,target2]*")) + "C" -> Just (pure ["C"]) + "L" -> Just (pure ["L"]) + "S" -> Just (pure ["S"]) + _ -> Nothing + where + wrap c = fmap (\s -> [[c], s]) + +cmdMonitor :: NetworkCommand [String] +cmdMonitor cs st args = + do sendMsg cs (ircMonitor (fmap Text.pack args)) + commandSuccess st + +cmdUsers :: ChannelCommand () +cmdUsers _ _ st _ = commandSuccess (changeSubfocus FocusUsers st) + +cmdChannelInfo :: ChannelCommand () +cmdChannelInfo _ _ st _ = commandSuccess (changeSubfocus FocusInfo st) + +cmdKnock :: NetworkCommand (String, String) +cmdKnock cs st (chan,message) = + do sendMsg cs (ircKnock (Text.pack chan) (Text.pack message)) + commandSuccess st + +cmdJoin :: NetworkCommand (String, Maybe String) +cmdJoin cs st (channels, mbKeys) = + do let network = view csNetwork cs + let channelId = mkId (Text.pack (takeWhile (/=',') channels)) + sendMsg cs (ircJoin (Text.pack channels) (Text.pack <$> mbKeys)) + commandSuccess + $ changeFocus (ChannelFocus network channelId) st + +-- | @/query@ command. Takes a channel or nickname and switches +-- focus to that target on the current network. +cmdQuery :: ClientCommand (String, String) +cmdQuery st (target, msg) = + case parseFocus (views clientFocus focusNetwork st) target of + Just (ChannelFocus net tgt) + + | null msg -> commandSuccess st' + + | 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' + where + firstTgt = mkId (Text.takeWhile (','/=) (idText tgt)) + st' = changeFocus (ChannelFocus net firstTgt) st + + _ -> commandFailureMsg "Bad target" st + +-- | 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 + + sendMsg cs (ircPrivmsg tgtTxt ("\^A" <> cmdTxt <> " " <> argTxt <> "\^A")) + chatCommand + (\src tgt -> Ctcp src tgt cmdTxt argTxt) + tgtTxt cs 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 + +-- | 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 + + 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 -} -> + NetworkState -> + ClientState -> + IO CommandResult +chatCommand mkmsg target cs st = + commandSuccess =<< chatCommand' mkmsg target cs st + +-- | Common logic for @/msg@ and @/notice@ returning the client state +chatCommand' :: + (UserInfo -> Identifier -> IrcMsg) -> + Text {- ^ target -} -> + NetworkState -> + ClientState -> + IO ClientState +chatCommand' con targetsTxt cs st = + do now <- getZonedTime + let targetTxts = Text.split (==',') targetsTxt + targetIds = mkId <$> targetTxts + !myNick = UserInfo (view csNick cs) "" "" + network = view csNetwork cs + entries = [ (targetId, + ClientMessage + { _msgTime = now + , _msgNetwork = network + , _msgBody = IrcBody (con myNick targetId) + }) + | targetId <- targetIds ] + + return $! foldl' (\acc (targetId, entry) -> + recordChannelMessage network targetId entry acc) + st + entries + +-- | Implementation of @/quote@. Parses arguments as a raw IRC command and +-- sends to the current network. +cmdQuote :: NetworkCommand String +cmdQuote cs st rest = + case parseRawIrcMsg (Text.pack (dropWhile (' '==) rest)) of + Nothing -> commandFailureMsg "failed to parse raw IRC command" st + Just raw -> + do sendMsg cs raw + commandSuccess st + +cmdAway :: NetworkCommand String +cmdAway cs st rest = + do sendMsg cs (ircAway (Text.pack rest)) + commandSuccess st + +cmdNick :: NetworkCommand String +cmdNick cs st nick = + do sendMsg cs (ircNick (Text.pack nick)) + commandSuccess st + +cmdPart :: ChannelCommand String +cmdPart channelId cs st rest = + do let msg = rest + sendMsg cs (ircPart channelId (Text.pack msg)) + commandSuccess st + +-- | This command is equivalent to chatting without a command. The primary use +-- at the moment is to be able to send a leading @/@ to chat easily. +cmdSay :: ChannelCommand String +cmdSay _ _ st rest = executeChat rest st + +-- | Implementation of @/me@ +cmdMe :: ChannelCommand String +cmdMe channelId cs st rest = + do now <- getZonedTime + let actionTxt = Text.pack ("\^AACTION " ++ rest ++ "\^A") + !myNick = UserInfo (view csNick cs) "" "" + network = view csNetwork cs + entry = ClientMessage + { _msgTime = now + , _msgNetwork = network + , _msgBody = IrcBody (Ctcp myNick channelId "ACTION" (Text.pack rest)) + } + sendMsg cs (ircPrivmsg (idText channelId) actionTxt) + commandSuccess + $! recordChannelMessage network channelId entry st + +-- | Treat the current text input as a chat message and send it. +executeChat :: + String {- ^ chat message -} -> + ClientState {- ^ client state -} -> + IO CommandResult {- ^ command result -} +executeChat msg st = + case view clientFocus st of + ChannelFocus network channel + | Just !cs <- preview (clientConnection network) st -> + do now <- getZonedTime + let msgTxt = Text.pack $ takeWhile (/='\n') msg + tgtTxt = idText channel + + (st1,allow) <- clientChatExtension network tgtTxt msgTxt st + + when allow (sendMsg cs (ircPrivmsg tgtTxt msgTxt)) + + let myNick = UserInfo (view csNick cs) "" "" + entry = ClientMessage + { _msgTime = now + , _msgNetwork = network + , _msgBody = IrcBody (Privmsg myNick channel msgTxt) } + commandSuccess $! recordChannelMessage network channel entry st1 + + _ -> commandFailureMsg "cannot send chat messages to this window" st diff --git a/src/Client/Commands/Connection.hs b/src/Client/Commands/Connection.hs new file mode 100644 --- /dev/null +++ b/src/Client/Commands/Connection.hs @@ -0,0 +1,110 @@ +{-# Language OverloadedStrings #-} +{-| +Module : Client.Commands.Connection +Description : Connection command implementations +Copyright : (c) Eric Mertens, 2016-2020 +License : ISC +Maintainer : emertens@gmail.com +-} + +module Client.Commands.Connection (connectionCommands) where + +import Client.Commands.Arguments.Spec +import Client.Commands.TabCompletion +import Client.Commands.Types +import Client.Commands.WordCompletion +import Client.Configuration +import Client.State +import Client.State.Focus +import Client.State.Network +import Control.Lens +import qualified Data.HashMap.Strict as HashMap +import qualified Data.Text as Text +import Irc.Commands (ircQuit) + +connectionCommands :: CommandSection +connectionCommands = CommandSection "Connection commands" + + [ Command + (pure "connect") + (simpleToken "network") + "Connect to \^Bnetwork\^B by name.\n\ + \\n\ + \If no name is configured the hostname is the 'name'.\n" + $ ClientCommand cmdConnect tabConnect + + , Command + (pure "reconnect") + (pure ()) + "Reconnect to the current network.\n" + $ ClientCommand cmdReconnect noClientTab + + , Command + (pure "disconnect") + (pure ()) + "Immediately terminate the current network connection.\n\ + \\n\ + \See also: /quit /exit\n" + $ NetworkCommand cmdDisconnect noNetworkTab + + , Command + (pure "quit") + (remainingArg "reason") + "Gracefully disconnect the current network connection.\n\ + \\n\ + \\^Breason\^B: optional quit reason\n\ + \\n\ + \See also: /disconnect /exit\n" + $ NetworkCommand cmdQuit simpleNetworkTab + + , Command + (pure "cert") + (pure ()) + "Show the TLS certificate for the current connection.\n" + $ NetworkCommand cmdCert noNetworkTab + + ] + +cmdConnect :: ClientCommand String +cmdConnect st networkStr = + do -- abort any existing connection before connecting + let network = Text.pack networkStr + st' <- addConnection 0 Nothing Nothing network =<< abortNetwork network st + commandSuccess + $ changeFocus (NetworkFocus network) st' + +cmdQuit :: NetworkCommand String +cmdQuit cs st rest = + do let msg = Text.pack rest + sendMsg cs (ircQuit msg) + commandSuccess st + +cmdDisconnect :: NetworkCommand () +cmdDisconnect cs st _ = + do st' <- abortNetwork (view csNetwork cs) st + commandSuccess st' + +-- | Reconnect to the currently focused network. It's possible +-- that we're not currently connected to a network, so +-- this is implemented as a client command. +cmdReconnect :: ClientCommand () +cmdReconnect st _ + | Just network <- views clientFocus focusNetwork st = + + do let tm = preview (clientConnection network . csLastReceived . folded) st + st' <- addConnection 0 tm Nothing network =<< abortNetwork network st + commandSuccess + $ changeFocus (NetworkFocus network) st' + + | otherwise = commandFailureMsg "command requires focused network" st + +-- | @/connect@ tab completes known server names +tabConnect :: Bool -> ClientCommand String +tabConnect isReversed st _ = + simpleTabCompletion plainWordCompleteMode [] networks isReversed st + where + networks = views clientConnections HashMap.keys st + ++ views (clientConfig . configServers) HashMap.keys st + +cmdCert :: NetworkCommand () +cmdCert _ st _ = commandSuccess (changeSubfocus FocusCert st) diff --git a/src/Client/Commands/DCC.hs b/src/Client/Commands/DCC.hs new file mode 100644 --- /dev/null +++ b/src/Client/Commands/DCC.hs @@ -0,0 +1,111 @@ +{-# Language OverloadedStrings #-} +{-| +Module : Client.Commands.DCC +Description : DCC command implementations +Copyright : (c) Eric Mertens, 2016-2020 +License : ISC +Maintainer : emertens@gmail.com +-} + +module Client.Commands.DCC (dccCommands) where + +import Client.Commands.Arguments.Spec +import Client.Commands.Chat (cmdCtcp) +import Client.Commands.TabCompletion +import Client.Commands.Types +import Client.Configuration +import Client.State +import Client.State.DCC +import Client.State.Focus +import Control.Applicative +import qualified Control.Concurrent.Async as Async +import Control.Lens +import System.Directory (doesDirectoryExist) +import System.FilePath (()) + +dccCommands :: CommandSection +dccCommands = CommandSection "DCC" + + [ Command + (pure "dcc") + (liftA2 (,) (optionalArg (simpleToken "[accept|cancel|clear|resume]")) + optionalNumberArg) + "Main access to the DCC subsystem with the following subcommands:\n\n\ + \ /dcc : Access to a list of pending offer and downloads\n\ + \ /dcc accept #n : start downloading the #n pending offer\n\ + \ /dcc resume #n : same as accept but appending to the file on `download-dir`\n\ + \ /dcc clear #n : remove the #n offer from the list \n\ + \ /dcc cancel #n : cancel the download #n \n\n" + $ ClientCommand cmdDcc noClientTab + ] + +-- | Implementation of @/dcc [(cancel|accept|resume)] [key] +cmdDcc :: ClientCommand (Maybe String, Maybe Int) +cmdDcc st (Nothing, Nothing) = commandSuccess (changeSubfocus FocusDCC st) +cmdDcc st (Just cmd, Just key) = checkAndBranch st cmd key +cmdDcc st _ = commandFailureMsg "Invalid syntax" st + +checkAndBranch :: ClientState -> String -> Int -> IO CommandResult +checkAndBranch st cmd key + | isCancel, NotExist <- curKeyStatus + = commandFailureMsg "No such DCC entry" st + | isCancel, curKeyStatus == Pending + = commandSuccess + $ set (clientDCC . dsOffers . ix key . dccStatus) UserKilled st + | isCancel, curKeyStatus /= Downloading + = commandFailureMsg "Transfer already stopped" st + | isCancel = Async.cancel threadId *> commandSuccess st + + | isClear, NotExist <- curKeyStatus + = commandFailureMsg "No such DCC entry" st + | isClear, curKeyStatus `elem` [Downloading, Pending] + = commandFailureMsg "Cancel the download first" st + | isClear = commandSuccess + $ set (clientDCC . dsOffers . at key) Nothing + $ set (clientDCC . dsTransfers . at key) Nothing st + + | isAcceptOrResume, curKeyStatus `elem` alreadyAcceptedSet + = commandFailureMsg "Offer already accepted" st + | isAcceptOrResume, NotExist <- curKeyStatus + = commandFailureMsg "No such DCC entry" st + | isAcceptOrResume + = do isDirectory <- doesDirectoryExist downloadPath + msize <- getFileOffset downloadPath + case (isDirectory, msize, cmd, mcs) of + (True, _, _, _) -> commandFailureMsg "DCC transfer would overwrite a directory" st + (_, Nothing, _, _) -> acceptOffer -- resume from 0 is accept + (_, _, "accept", _) -> acceptOffer -- overwrite file + (_, Just size, "resume", Just cs) -> resumeOffer size cs + _ -> commandFailureMsg "Unknown case" st + + | otherwise = commandFailureMsg "Invalid syntax" st + where + -- General + isAcceptOrResume = cmd `elem` ["accept", "resume"] + isCancel = cmd == "cancel" + isClear = cmd == "clear" + dccState = view clientDCC st + curKeyStatus = statusAtKey key dccState + alreadyAcceptedSet = [ CorrectlyFinished, UserKilled, LostConnection + , Downloading] + + -- For cancel, other cases handled on the guards + threadId = st ^?! clientDCC . dsTransfers . ix key . dtThread . _Just + + -- Common values for resume or accept + Just offer = view (clientDCC . dsOffers . at key) st -- guarded exist + updChan = view clientDCCUpdates st + downloadDir = view (clientConfig . configDownloadDir) st + downloadPath = downloadDir _dccFileName offer + mcs = preview (clientConnection (_dccNetwork offer)) st + + -- Actual workhorses for the commands + acceptOffer = + do newDCCState <- supervisedDownload downloadDir key updChan dccState + commandSuccess (set clientDCC newDCCState st) + + resumeOffer size cs = + let newOffer = offer { _dccOffset = size } + (target, txt) = resumeMsg size newOffer + st' = set (clientDCC . dsOffers . at key) (Just newOffer) st + in cmdCtcp cs st' (target, "DCC", txt) diff --git a/src/Client/Commands/Operator.hs b/src/Client/Commands/Operator.hs new file mode 100644 --- /dev/null +++ b/src/Client/Commands/Operator.hs @@ -0,0 +1,127 @@ +{-# Language OverloadedStrings #-} +{-| +Module : Client.Commands.Operator +Description : Operator command implementations +Copyright : (c) Eric Mertens, 2016-2020 +License : ISC +Maintainer : emertens@gmail.com +-} + +module Client.Commands.Operator (operatorCommands) where + +import Control.Applicative +import Client.Commands.Arguments.Spec +import Client.Commands.TabCompletion +import Client.Commands.Types +import Client.State.Network (sendMsg) +import qualified Data.Text as Text +import Irc.Commands + +operatorCommands :: CommandSection +operatorCommands = CommandSection "Network operator commands" + + [ Command + (pure "oper") + (liftA2 (,) (simpleToken "user") (simpleToken "password")) + "Authenticate as a server operator.\n" + $ NetworkCommand cmdOper noNetworkTab + + , Command + (pure "kill") + (liftA2 (,) (simpleToken "client") (remainingArg "reason")) + "Kill a client connection to the server.\n" + $ NetworkCommand cmdKill simpleNetworkTab + + , Command + (pure "kline") + (liftA3 (,,) (simpleToken "minutes") (simpleToken "user@host") (remainingArg "reason")) + "Ban a client from the server.\n" + $ NetworkCommand cmdKline simpleNetworkTab + + , Command + (pure "unkline") + (simpleToken "user@host") + "Unban a client from the server.\n" + $ NetworkCommand cmdUnkline simpleNetworkTab + + , Command + (pure "testline") + (simpleToken "[[nick!]user@]host") + "Check matching I/K/D lines for a [[nick!]user@]host\n" + $ NetworkCommand cmdTestline simpleNetworkTab + + , Command + (pure "testmask") + (liftA2 (,) (simpleToken "[nick!]user@host") (remainingArg "[gecos]")) + "Test how many local and global clients match a mask.\n" + $ NetworkCommand cmdTestmask simpleNetworkTab + + , Command + (pure "masktrace") + (liftA2 (,) (simpleToken "[nick!]user@host") (remainingArg "[gecos]")) + "Outputs a list of local users matching the given masks.\n" + $ NetworkCommand cmdMasktrace simpleNetworkTab + + , Command + (pure "trace") + (optionalArg (liftA2 (,) (simpleToken "[server | nick]") (optionalArg (simpleToken "[server]")))) + "Outputs a list users on a server.\n" + $ NetworkCommand cmdTrace simpleNetworkTab + + , Command + (pure "map") + (pure ()) + "Display network map.\n" + $ NetworkCommand cmdMap simpleNetworkTab + + ] + +cmdKill :: NetworkCommand (String, String) +cmdKill cs st (client,rest) = + do sendMsg cs (ircKill (Text.pack client) (Text.pack rest)) + commandSuccess st + +cmdKline :: NetworkCommand (String, String, String) +cmdKline cs st (minutes, mask, reason) = + do sendMsg cs (ircKline (Text.pack minutes) (Text.pack mask) (Text.pack reason)) + commandSuccess st + +cmdUnkline :: NetworkCommand String +cmdUnkline cs st mask = + do sendMsg cs (ircUnkline (Text.pack mask)) + commandSuccess st + +cmdTestline :: NetworkCommand String +cmdTestline cs st mask = + do sendMsg cs (ircTestline (Text.pack mask)) + commandSuccess st + +cmdTestmask :: NetworkCommand (String, String) +cmdTestmask cs st (mask, gecos) = + do sendMsg cs (ircTestmask (Text.pack mask) (Text.pack gecos)) + commandSuccess st + +cmdMasktrace :: NetworkCommand (String, String) +cmdMasktrace cs st (mask, gecos) = + do sendMsg cs (ircMasktrace (Text.pack mask) (Text.pack gecos)) + commandSuccess st + +cmdTrace :: NetworkCommand (Maybe (String, Maybe String)) +cmdTrace cs st args = + do let argsList = + case args of + Nothing -> [] + Just (x, Nothing) -> [x] + Just (x, Just y) -> [x, y] + sendMsg cs (ircTrace (map Text.pack argsList)) + commandSuccess st + +cmdMap :: NetworkCommand () +cmdMap cs st _ = + do sendMsg cs ircMap + commandSuccess st + +cmdOper :: NetworkCommand (String, String) +cmdOper cs st (user, pass) = + do sendMsg cs (ircOper (Text.pack user) (Text.pack pass)) + commandSuccess st diff --git a/src/Client/Commands/Queries.hs b/src/Client/Commands/Queries.hs new file mode 100644 --- /dev/null +++ b/src/Client/Commands/Queries.hs @@ -0,0 +1,195 @@ +{-# Language OverloadedStrings #-} +{-| +Module : Client.Commands.Queries +Description : Query command implementations +Copyright : (c) Eric Mertens, 2016-2020 +License : ISC +Maintainer : emertens@gmail.com +-} + +module Client.Commands.Queries (queryCommands) where + +import Control.Applicative +import Client.Commands.Arguments.Spec +import Client.Commands.TabCompletion +import Client.Commands.Types +import Client.State.Network (sendMsg) +import qualified Data.Text as Text +import Irc.Commands + +queryCommands :: CommandSection +queryCommands = CommandSection "Queries" + + [ Command + (pure "who") + (remainingArg "arguments") + "Send WHO query to server with given arguments.\n" + $ NetworkCommand cmdWho simpleNetworkTab + + , Command + (pure "whois") + (remainingArg "arguments") + "Send WHOIS query to server with given arguments.\n" + $ NetworkCommand cmdWhois simpleNetworkTab + + , Command + (pure "whowas") + (remainingArg "arguments") + "Send WHOWAS query to server with given arguments.\n" + $ NetworkCommand cmdWhowas simpleNetworkTab + + , Command + (pure "ison") + (remainingArg "arguments") + "Send ISON query to server with given arguments.\n" + $ NetworkCommand cmdIson simpleNetworkTab + + , Command + (pure "userhost") + (remainingArg "arguments") + "Send USERHOST query to server with given arguments.\n" + $ NetworkCommand cmdUserhost simpleNetworkTab + + , Command + (pure "time") + (optionalArg (simpleToken "[servername]")) + "Send TIME query to server with given arguments.\n" + $ NetworkCommand cmdTime simpleNetworkTab + + , Command + (pure "stats") + (remainingArg "arguments") + "Send STATS query to server with given arguments.\n" + $ NetworkCommand cmdStats simpleNetworkTab + + , Command + (pure "lusers") + (optionalArg (liftA2 (,) (simpleToken "mask") (optionalArg (simpleToken "[servername]")))) + "Send LUSERS query to server with given arguments.\n" + $ NetworkCommand cmdLusers simpleNetworkTab + + , Command + (pure "motd") (optionalArg (simpleToken "[servername]")) + "Send MOTD query to server.\n" + $ NetworkCommand cmdMotd simpleNetworkTab + + , Command + (pure "admin") (optionalArg (simpleToken "[servername]")) + "Send ADMIN query to server.\n" + $ NetworkCommand cmdAdmin simpleNetworkTab + + , Command + (pure "rules") (optionalArg (simpleToken "[servername]")) + "Send RULES query to server.\n" + $ NetworkCommand cmdRules simpleNetworkTab + + , Command + (pure "info") (pure ()) + "Send INFO query to server.\n" + $ NetworkCommand cmdInfo noNetworkTab + + , Command + (pure "list") (remainingArg "arguments") + "Send LIST query to server.\n" + $ NetworkCommand cmdList simpleNetworkTab + + , Command + (pure "links") + (remainingArg "arguments") + "Send LINKS query to server with given arguments.\n" + $ NetworkCommand cmdLinks simpleNetworkTab + + , Command + (pure "version") (optionalArg (simpleToken "[servername]")) + "Send VERSION query to server.\n" + $ NetworkCommand cmdVersion simpleNetworkTab + + ] + +cmdInfo :: NetworkCommand () +cmdInfo cs st _ = + do sendMsg cs ircInfo + commandSuccess st + +cmdVersion :: NetworkCommand (Maybe String) +cmdVersion cs st mbservername = + do sendMsg cs $ ircVersion $ case mbservername of + Just s -> Text.pack s + Nothing -> "" + commandSuccess st + +cmdList :: NetworkCommand String +cmdList cs st rest = + do sendMsg cs (ircList (Text.pack <$> words rest)) + commandSuccess st + +cmdLusers :: NetworkCommand (Maybe (String, 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] + commandSuccess st + +cmdMotd :: NetworkCommand (Maybe String) +cmdMotd cs st mbservername = + do sendMsg cs $ ircMotd $ case mbservername of + Just s -> Text.pack s + Nothing -> "" + commandSuccess st + +cmdAdmin :: NetworkCommand (Maybe String) +cmdAdmin cs st mbservername = + do sendMsg cs $ ircAdmin $ case mbservername of + Just s -> Text.pack s + Nothing -> "" + commandSuccess st + +cmdRules :: NetworkCommand (Maybe String) +cmdRules cs st mbservername = + do sendMsg cs $ ircRules $ + case mbservername of + Just s -> Text.pack s + Nothing -> "" + commandSuccess st + +cmdStats :: NetworkCommand String +cmdStats cs st rest = + do sendMsg cs (ircStats (Text.pack <$> words rest)) + commandSuccess st + +cmdLinks :: NetworkCommand String +cmdLinks cs st rest = + do sendMsg cs (ircLinks (Text.pack <$> words rest)) + commandSuccess st + +cmdTime :: NetworkCommand (Maybe String) +cmdTime cs st arg = + do sendMsg cs (ircTime (maybe "" Text.pack arg)) + commandSuccess st + +cmdWhois :: NetworkCommand String +cmdWhois cs st rest = + do sendMsg cs (ircWhois (Text.pack <$> words rest)) + commandSuccess st + +cmdWho :: NetworkCommand String +cmdWho cs st rest = + do sendMsg cs (ircWho (Text.pack <$> words rest)) + commandSuccess st + +cmdWhowas :: NetworkCommand String +cmdWhowas cs st rest = + do sendMsg cs (ircWhowas (Text.pack <$> words rest)) + commandSuccess st + +cmdIson :: NetworkCommand String +cmdIson cs st rest = + do sendMsg cs (ircIson (Text.pack <$> words rest)) + commandSuccess st + +cmdUserhost :: NetworkCommand String +cmdUserhost cs st rest = + do sendMsg cs (ircUserhost (Text.pack <$> words rest)) + commandSuccess st diff --git a/src/Client/Commands/TabCompletion.hs b/src/Client/Commands/TabCompletion.hs new file mode 100644 --- /dev/null +++ b/src/Client/Commands/TabCompletion.hs @@ -0,0 +1,107 @@ +{-| +Module : Client.Commands.TabCompletion +Description : Common tab-completion logic +Copyright : (c) Eric Mertens, 2016-2020 +License : ISC +Maintainer : emertens@gmail.com +-} + +module Client.Commands.TabCompletion where + +import Client.Commands.Types +import Client.Commands.WordCompletion +import Client.Message +import Client.State +import Client.State.Focus +import Client.State.Network +import Client.State.Window +import Client.State.Channel +import Control.Lens +import qualified Data.HashMap.Strict as HashMap +import Irc.Identifier +import Irc.UserInfo + +-- | Provides no tab completion for client commands +noClientTab :: Bool -> ClientCommand String +noClientTab _ st _ = commandFailure st + +-- | Provides no tab completion for network commands +noNetworkTab :: Bool -> NetworkCommand String +noNetworkTab _ _ st _ = commandFailure st + +-- | Provides no tab completion for channel commands +noChannelTab :: Bool -> ChannelCommand String +noChannelTab _ _ _ st _ = commandFailure st + +-- | Provides nickname based tab completion for client commands +simpleClientTab :: Bool -> ClientCommand String +simpleClientTab isReversed st _ = + nickTabCompletion isReversed st + +-- | Provides nickname based tab completion for network commands +simpleNetworkTab :: Bool -> NetworkCommand String +simpleNetworkTab isReversed _ st _ = + nickTabCompletion isReversed st + +-- | Provides nickname based tab completion for channel commands +simpleChannelTab :: Bool -> ChannelCommand String +simpleChannelTab isReversed _ _ st _ = + nickTabCompletion isReversed st + +simpleTabCompletion :: + Prefix a => + WordCompletionMode {- ^ word completion mode -} -> + [a] {- ^ hints -} -> + [a] {- ^ all completions -} -> + Bool {- ^ reversed order -} -> + ClientState {- ^ client state -} -> + IO CommandResult +simpleTabCompletion mode hints completions isReversed st = + case traverseOf clientTextBox tryCompletion st of + Nothing -> commandFailure st + Just st' -> commandSuccess st' + where + tryCompletion = wordComplete mode isReversed hints completions + +-- | Complete the nickname at the current cursor position using the +-- userlist for the currently focused channel (if any) +nickTabCompletion :: Bool {- ^ reversed -} -> ClientState -> IO CommandResult +nickTabCompletion isReversed st = + simpleTabCompletion mode hint completions isReversed st + where + hint = activeNicks st + completions = currentCompletionList st + mode = currentNickCompletionMode st + +activeNicks :: + ClientState -> + [Identifier] +activeNicks st = + case view clientFocus st of + focus@(ChannelFocus network channel) -> + toListOf + ( clientWindows . ix focus + . winMessages . each + . wlSummary . folding summaryActor + . filtered isActive + . filtered isNotSelf ) st + where + isActive n = HashMap.member n userMap + self = preview ( clientConnection network . csNick ) st + isNotSelf n = case self of + Nothing -> True + Just s -> n /= s + userMap = view ( clientConnection network + . csChannels . ix channel + . chanUsers) st + + _ -> [] + + where + -- 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 + diff --git a/src/Client/Commands/Toggles.hs b/src/Client/Commands/Toggles.hs new file mode 100644 --- /dev/null +++ b/src/Client/Commands/Toggles.hs @@ -0,0 +1,69 @@ +{-# Language OverloadedStrings #-} +{-| +Module : Client.Commands.Toggles +Description : View modality command implementations +Copyright : (c) Eric Mertens, 2016-2020 +License : ISC +Maintainer : emertens@gmail.com +-} + +module Client.Commands.Toggles (togglesCommands) where + +import Client.Commands.TabCompletion +import Client.Commands.Types +import Client.Configuration +import Client.State +import Control.Lens + +togglesCommands :: CommandSection +togglesCommands = CommandSection "View toggles" + + [ Command + (pure "toggle-detail") + (pure ()) + "Toggle detailed message view.\n" + $ ClientCommand cmdToggleDetail noClientTab + + , Command + (pure "toggle-activity-bar") + (pure ()) + "Toggle detailed detailed activity information in status bar.\n" + $ ClientCommand cmdToggleActivityBar noClientTab + + , Command + (pure "toggle-show-ping") + (pure ()) + "Toggle visibility of ping round-trip time.\n" + $ ClientCommand cmdToggleShowPing noClientTab + + , Command + (pure "toggle-metadata") + (pure ()) + "Toggle visibility of metadata in chat windows.\n" + $ ClientCommand cmdToggleMetadata noClientTab + + , Command + (pure "toggle-layout") + (pure ()) + "Toggle multi-window layout mode.\n" + $ ClientCommand cmdToggleLayout noClientTab + + ] + +cmdToggleDetail :: ClientCommand () +cmdToggleDetail st _ = commandSuccess (over clientDetailView not st) + +cmdToggleActivityBar :: ClientCommand () +cmdToggleActivityBar st _ = commandSuccess (over clientActivityBar not st) + +cmdToggleShowPing :: ClientCommand () +cmdToggleShowPing st _ = commandSuccess (over clientShowPing not st) + +cmdToggleMetadata :: ClientCommand () +cmdToggleMetadata st _ = commandSuccess (clientToggleHideMeta st) + +cmdToggleLayout :: ClientCommand () +cmdToggleLayout st _ = commandSuccess (set clientScroll 0 (over clientLayout aux st)) + where + aux OneColumn = TwoColumn + aux TwoColumn = OneColumn diff --git a/src/Client/Commands/Types.hs b/src/Client/Commands/Types.hs new file mode 100644 --- /dev/null +++ b/src/Client/Commands/Types.hs @@ -0,0 +1,87 @@ +{-# Language ExistentialQuantification #-} +{-| +Module : Client.Commands.Types +Description : Types used to implement client commands +Copyright : (c) Eric Mertens, 2016-2020 +License : ISC +Maintainer : emertens@gmail.com +-} + +module Client.Commands.Types where + +import Client.State (ClientState, clientErrorMsg) +import Client.State.Network (NetworkState) +import Data.Text (Text) +import Data.List.NonEmpty (NonEmpty) +import Client.Commands.Arguments.Spec +import Irc.Identifier (Identifier) +import Control.Lens + +-- | Possible results of running a command +data CommandResult + -- | Continue running the client, consume input if command was from input + = CommandSuccess ClientState + -- | Continue running the client, report an error + | CommandFailure ClientState + -- | Client should close + | CommandQuit ClientState + + +-- | Type of commands that always work +type ClientCommand a = ClientState -> a {- ^ arguments -} -> IO CommandResult + +-- | Type of commands that require an active network to be focused +type NetworkCommand a = NetworkState {- ^ current network -} -> ClientCommand a + +-- | Type of commands that require an active channel to be focused +type ChannelCommand a = Identifier {- ^ focused channel -} -> NetworkCommand a + + +-- | Pair of implementations for executing a command and tab completing one. +-- The tab-completion logic is extended with a Bool +-- indicating that tab completion should be reversed +data CommandImpl a + -- | no requirements + = ClientCommand (ClientCommand a) (Bool -> ClientCommand String) + -- | requires an active network + | NetworkCommand (NetworkCommand a) (Bool -> NetworkCommand String) + -- | requires an active chat window + | ChatCommand (ChannelCommand a) (Bool -> ChannelCommand String) + -- | requires an active channel window + | ChannelCommand (ChannelCommand a) (Bool -> ChannelCommand String) + + +-- | A command is a list of aliases, an argument specification, implementation, +-- and documentation. The arguments and implementation must match so that +-- the parsed arguments will match what the implementation expects. +data Command = forall a. Command + { -- | Names of this command, first in the list is the "primary" name + cmdNames :: NonEmpty Text + -- | Specification of the arguments of the command + , cmdArgumentSpec :: Args ClientState a + -- | Multi-line IRC-formatted documentation text used for @/help@ + , cmdDocumentation :: Text + -- | Implementation of the command for both execution and tab completion + , cmdImplementation :: CommandImpl a + } + +-- | A command section is a logical grouping of commands. This allows for +-- showing more structure in the help menu system. +data CommandSection = CommandSection + { cmdSectionName :: Text + , cmdSectionCmds :: [Command] + } + +-- | Consider the text entry successful and resume the client +commandSuccess :: Monad m => ClientState -> m CommandResult +commandSuccess = return . CommandSuccess + +-- | Consider the text entry a failure and resume the client +commandFailure :: Monad m => ClientState -> m CommandResult +commandFailure = return . CommandFailure + +-- | Command failure with an error message printed to client window +commandFailureMsg :: Text -> ClientState -> IO CommandResult +commandFailureMsg e st = + return $! CommandFailure $! set clientErrorMsg (Just e) st + diff --git a/src/Client/Commands/Window.hs b/src/Client/Commands/Window.hs new file mode 100644 --- /dev/null +++ b/src/Client/Commands/Window.hs @@ -0,0 +1,508 @@ +{-# Language OverloadedStrings #-} +{-| +Module : Client.Commands.Window +Description : Window command implementations +Copyright : (c) Eric Mertens, 2016-2020 +License : ISC +Maintainer : emertens@gmail.com +-} + +module Client.Commands.Window (windowCommands, parseFocus) where + +import Client.Commands.Arguments.Spec +import Client.Commands.TabCompletion +import Client.Commands.Types +import Client.Commands.WordCompletion +import Client.Image.PackedImage +import Client.Mask (buildMask) +import Client.State +import Client.State.Focus +import Client.State.Network +import Client.State.Window (emptyWindow, WindowLines((:-), Nil), wlFullImage, winMessages) +import Control.Applicative +import Control.Exception +import Control.Lens +import Data.Foldable +import Data.List ((\\), nub) +import qualified Client.State.EditBox as Edit +import Data.HashSet (HashSet) +import Data.List.NonEmpty (NonEmpty((:|))) +import qualified Data.HashMap.Strict as HashMap +import qualified Data.Map as Map +import Data.Text (Text) +import qualified Data.Text as Text +import qualified Data.Text.Lazy as LText +import qualified Data.Text.Lazy.IO as LText +import Irc.Identifier + +windowCommands :: CommandSection +windowCommands = CommandSection "Window management" + ------------------------------------------------------------------------ + + [ Command + (pure "focus") + (liftA2 (,) (simpleToken "network") (optionalArg (simpleToken "[target]"))) + "Change the focused window.\n\ + \\n\ + \When only \^Bnetwork\^B is specified this switches to the network status window.\n\ + \When \^Bnetwork\^B and \^Btarget\^B are specified this switches to that chat window.\n\ + \\n\ + \Nickname and channels can be specified in the \^Btarget\^B parameter.\n\ + \See also: /query (aliased /c /channel) to switch to a target on the current network.\n" + $ ClientCommand cmdFocus tabFocus + + , Command + ("c" :| ["channel"]) + (simpleToken "focus") + "\^BParameters:\^B\n\ + \\n\ + \ focuses: Focus name\n\ + \\n\ + \\^BDescription:\^B\n\ + \\n\ + \ This command sets the current window focus. When\n\ + \ no network is specified, the current network will\n\ + \ be used.\n\ + \\n\ + \ Client: *\n\ + \ Network: \^_network\^_:\n\ + \ Channel: \^_#channel\^_\n\ + \ Channel: \^_network\^_:\^_#channel\^_\n\ + \ User: \^_nick\^_\n\ + \ User: \^_network\^_:\^_nick\^_\n\ + \\n\ + \\^BExamples:\^B\n\ + \\n\ + \ /c fn:#haskell\n\ + \ /c #haskell\n\ + \ /c fn:\n\ + \ /c *:\n\ + \\n\ + \\^BSee also:\^B focus\n" + $ ClientCommand cmdChannel tabChannel + + , Command + (pure "clear") + (optionalArg (liftA2 (,) (simpleToken "[network]") (optionalArg (simpleToken "[channel]")))) + "Clear a window.\n\ + \\n\ + \If no arguments are provided the current window is cleared.\n\ + \If \^Bnetwork\^B is provided the that network window is cleared.\n\ + \If \^Bnetwork\^B and \^Bchannel\^B are provided that chat window is cleared.\n\ + \If \^Bnetwork\^B is provided and \^Bchannel\^B is \^B*\^O all windows for that network are cleared.\n\ + \\n\ + \If a window is cleared and no longer active that window will be removed from the client.\n" + $ ClientCommand cmdClear tabFocus + + , Command + (pure "windows") + (optionalArg (simpleToken "[kind]")) + "Show a list of all windows with an optional argument to limit the kinds of windows listed.\n\ + \\n\ + \\^Bkind\^O: one of \^Bnetworks\^O, \^Bchannels\^O, \^Busers\^O\n\ + \\n" + $ ClientCommand cmdWindows tabWindows + + , Command + (pure "splits") + (remainingArg "focuses") + "\^BParameters:\^B\n\ + \\n\ + \ focuses: List of focus names\n\ + \\n\ + \\^BDescription:\^B\n\ + \\n\ + \ This command sents the set of focuses that will always\n\ + \ be visible, even when unfocused. When the client is focused\n\ + \ to an active network, the network can be omitted when\n\ + \ specifying a focus. If no focuses are listed, they will\n\ + \ all be cleared.\n\ + \\n\ + \ Client: *\n\ + \ Network: \^_network\^_:\n\ + \ Channel: \^_#channel\^_\n\ + \ Channel: \^_network\^_:\^_#channel\^_\n\ + \ User: \^_nick\^_\n\ + \ User: \^_network\^_:\^_nick\^_\n\ + \\n\ + \\^BExamples:\^B\n\ + \\n\ + \ /splits * fn:#haskell fn:chanserv\n\ + \ /splits #haskell #haskell-lens nickserv\n\ + \ /splits\n\ + \\n\ + \\^BSee also:\^B splits+, splits-\n" + $ ClientCommand cmdSplits tabSplits + + , Command + (pure "splits+") + (remainingArg "focuses") + "Add windows to the splits list. Omit the list of focuses to add the\ + \ current window.\n\ + \\n\ + \\^Bfocuses\^B: space delimited list of focus names.\n\ + \\n\ + \Client: *\n\ + \Network: \^BNETWORK\^B\n\ + \Channel: \^BNETWORK\^B:\^B#CHANNEL\^B\n\ + \User: \^BNETWORK\^B:\^BNICK\^B\n\ + \\n\ + \If the network part is omitted, the current network will be used.\n" + $ ClientCommand cmdSplitsAdd tabSplits + + , Command + (pure "splits-") + (remainingArg "focuses") + "Remove windows from the splits list. Omit the list of focuses to\ + \ remove the current window.\n\ + \\n\ + \\^Bfocuses\^B: space delimited list of focus names.\n\ + \\n\ + \Client: *\n\ + \Network: \^BNETWORK\^B\n\ + \Channel: \^BNETWORK\^B:\^B#CHANNEL\^B\n\ + \User: \^BNETWORK\^B:\^BNICK\^B\n\ + \\n\ + \If the network part is omitted, the current network will be used.\n" + $ ClientCommand cmdSplitsDel tabActiveSplits + + , Command + (pure "ignore") + (remainingArg "masks") + "\^BParameters:\^B\n\ + \\n\ + \ masks: List of masks\n\ + \\n\ + \\^BDescription:\^B\n\ + \\n\ + \ Toggle the soft-ignore on each of the space-delimited given\n\ + \ nicknames. Ignores can use \^B*\^B (many) and \^B?\^B (one) wildcards.\n\ + \ Masks can be of the form: nick[[!user]@host]\n\ + \ Masks use a case-insensitive comparison.\n\ + \\n\ + \ If no masks are specified the current ignore list is displayed.\n\ + \\n\ + \\^BExamples:\^B\n\ + \\n\ + \ /ignore\n\ + \ /ignore nick1 nick2 nick3\n\ + \ /ignore nick@host\n\ + \ /ignore nick!user@host\n\ + \ /ignore *@host\n\ + \ /ignore *!baduser@*\n" + $ ClientCommand cmdIgnore tabIgnore + + , Command + (pure "grep") + (remainingArg "regular-expression") + "Set the persistent regular expression.\n\ + \\n\ + \\^BFlags:\^B\n\ + \ -An Show n messages after match\n\ + \ -Bn Show n messages before match\n\ + \ -Cn Show n messages before and after match\n\ + \ -i Case insensitive match\n\ + \ -v Invert pattern match\n\ + \ -- Stop processing flags\n\ + \\n\ + \Clear the regular expression by calling this without an argument.\n\ + \\n\ + \\^B/grep\^O is case-sensitive.\n" + $ ClientCommand cmdGrep simpleClientTab + + , Command + (pure "dump") + (simpleToken "filename") + "Dump current buffer to file.\n" + $ ClientCommand cmdDump simpleClientTab + + , Command + (pure "mentions") + (pure ()) + "Show a list of all message that were highlighted as important.\n\ + \\n\ + \When using \^B/grep\^B the important messages are those matching\n\ + \the regular expression instead.\n" + $ ClientCommand cmdMentions noClientTab + + ] + +-- | Implementation of @/grep@ +cmdGrep :: ClientCommand String +cmdGrep st str + | null str = commandSuccess (set clientRegex Nothing st) + | otherwise = + case buildMatcher str of + Nothing -> commandFailureMsg "bad grep" st + Just r -> commandSuccess (set clientRegex (Just r) st) + +-- | Implementation of @/windows@ command. Set subfocus to Windows. +cmdWindows :: ClientCommand (Maybe String) +cmdWindows st arg = + case arg of + Nothing -> success AllWindows + Just "networks" -> success NetworkWindows + Just "channels" -> success ChannelWindows + Just "users" -> success UserWindows + _ -> commandFailureMsg errmsg st + where + errmsg = "/windows expected networks, channels, or users" + success x = + commandSuccess (changeSubfocus (FocusWindows x) st) + +-- | Implementation of @/mentions@ command. Set subfocus to Mentions. +cmdMentions :: ClientCommand () +cmdMentions st _ = commandSuccess (changeSubfocus FocusMentions st) + +cmdIgnore :: ClientCommand String +cmdIgnore st rest = + case mkId <$> Text.words (Text.pack rest) of + [] -> commandSuccess (changeSubfocus FocusIgnoreList st) + xs -> commandSuccess st2 + where + (newIgnores, st1) = (clientIgnores <%~ updateIgnores) st + st2 = set clientIgnoreMask (buildMask (toList newIgnores)) st1 + + updateIgnores :: HashSet Identifier -> HashSet Identifier + updateIgnores s = foldl' updateIgnore s xs + + updateIgnore s x = over (contains x) not s + +-- | Complete the nickname at the current cursor position using the +-- userlist for the currently focused channel (if any) +tabIgnore :: Bool {- ^ reversed -} -> ClientCommand String +tabIgnore isReversed st _ = + simpleTabCompletion mode hint completions isReversed st + where + hint = activeNicks st + completions = currentCompletionList st ++ views clientIgnores toList st + mode = currentNickCompletionMode st + +-- | Implementation of @/splits@ +cmdSplits :: ClientCommand String +cmdSplits st str = + withSplitFocuses st str $ \args -> + commandSuccess (setExtraFocus (nub args) st) + + +-- | Implementation of @/splits+@. When no focuses are provided +-- the current focus is used instead. +cmdSplitsAdd :: ClientCommand String +cmdSplitsAdd st str = + withSplitFocuses st str $ \args -> + let args' + | null args = [(view clientFocus st, view clientSubfocus st)] + | otherwise = args + extras = nub (args' ++ view clientExtraFocus st) + + in commandSuccess (setExtraFocus extras st) + +-- | Implementation of @/splits-@. When no focuses are provided +-- the current focus is used instead. +cmdSplitsDel :: ClientCommand String +cmdSplitsDel st str = + withSplitFocuses st str $ \args -> + let args' + | null args = [(view clientFocus st, view clientSubfocus st)] + | otherwise = args + extras = view clientExtraFocus st \\ args' + + in commandSuccess (setExtraFocus extras st) + +withSplitFocuses :: + ClientState -> + String -> + ([(Focus, Subfocus)] -> IO CommandResult) -> + IO CommandResult +withSplitFocuses st str k = + case mb of + Nothing -> commandFailureMsg "unable to parse arguments" st + Just args -> k [(x, FocusMessages) | x <- args] + where + mb = traverse + (parseFocus (views clientFocus focusNetwork st)) + (words str) + +-- | Parses a single focus name given a default network. +parseFocus :: + Maybe Text {- ^ default network -} -> + String {- ^ @[network:]target@ -} -> + Maybe Focus +parseFocus mbNet x = + case break (==':') x of + ("*","") -> pure Unfocused + (net,_:"") -> pure (NetworkFocus (Text.pack net)) + (net,_:chan) -> pure (ChannelFocus (Text.pack net) (mkId (Text.pack chan))) + (chan,"") -> mbNet <&> \net -> + ChannelFocus net (mkId (Text.pack chan)) + +cmdFocus :: ClientCommand (String, Maybe String) +cmdFocus st (network, mbChannel) + | network == "*" = commandSuccess (changeFocus Unfocused st) + | otherwise = + case mbChannel of + Nothing -> + let focus = NetworkFocus (Text.pack network) in + commandSuccess (changeFocus focus st) + Just channel -> + let focus = ChannelFocus (Text.pack network) (mkId (Text.pack channel)) in + commandSuccess + $ changeFocus focus st + +tabWindows :: Bool -> ClientCommand String +tabWindows isReversed st _ = + simpleTabCompletion plainWordCompleteMode [] completions isReversed st + where + completions = ["networks","channels","users"] :: [Text] + +-- | Tab completion for @/splits-@. This completes only from the list of active +-- entries in the splits list. +tabActiveSplits :: Bool -> ClientCommand String +tabActiveSplits isReversed st _ = + simpleTabCompletion plainWordCompleteMode [] completions isReversed st + where + completions = currentNetSplits <> currentSplits + currentSplits = [renderSplitFocus x | (x, FocusMessages) <- view clientExtraFocus st] + currentNetSplits = + [ idText chan + | (ChannelFocus net chan, FocusMessages) <- view clientExtraFocus st + , views clientFocus focusNetwork st == Just net + ] + +-- | When used on a channel that the user is currently +-- joined to this command will clear the messages but +-- preserve the window. When used on a window that the +-- user is not joined to this command will delete the window. +cmdClear :: ClientCommand (Maybe (String, Maybe String)) +cmdClear st args = + case args of + Nothing -> clearFocus (view clientFocus st) + Just ("*", Nothing ) -> clearFocus Unfocused + Just (network, Nothing ) -> clearFocus (NetworkFocus (Text.pack network)) + Just (network, Just "*" ) -> clearNetworkWindows network + Just (network, Just channel) -> clearFocus (ChannelFocus (Text.pack network) (mkId (Text.pack channel))) + where + clearNetworkWindows network + = commandSuccess + $ foldl' (flip clearFocus1) st + $ filter (\x -> focusNetwork x == Just (Text.pack network)) + $ views clientWindows Map.keys st + + clearFocus focus = commandSuccess (clearFocus1 focus st) + + clearFocus1 focus st' = focusEffect (windowEffect st') + where + windowEffect = set (clientWindows . at focus) + (if isActive then Just emptyWindow else Nothing) + + focusEffect + | noChangeNeeded = id + | prevExists = changeFocus prev + | otherwise = advanceFocus + where + noChangeNeeded = isActive || view clientFocus st' /= focus + prevExists = has (clientWindows . ix prev) st' + + prev = view clientPrevFocus st + + isActive = + case focus of + Unfocused -> False + NetworkFocus network -> has (clientConnection network) st' + ChannelFocus network channel -> has (clientConnection network + .csChannels . ix channel) st' + +-- | Tab completion for @/splits[+]@. When given no arguments this +-- populates the current list of splits, otherwise it tab completes +-- all of the currently available windows. +tabSplits :: Bool -> ClientCommand String +tabSplits isReversed st rest + + -- If no arguments, populate the current splits + | all (' '==) rest = + let cmd = unwords $ "/splits" + : [Text.unpack (renderSplitFocus x) | (x, FocusMessages) <- view clientExtraFocus st] + newline = Edit.endLine cmd + in commandSuccess (set (clientTextBox . Edit.line) newline st) + + -- Tab complete the available windows. Accepts either fully qualified + -- window names or current network names without the ':' + | otherwise = + let completions = currentNet <> allWindows + allWindows = renderSplitFocus <$> views clientWindows Map.keys st + currentNet = case views clientFocus focusNetwork st of + Just net -> idText <$> channelWindowsOnNetwork net st + Nothing -> [] + in simpleTabCompletion plainWordCompleteMode [] completions isReversed st + +-- | Render a entry from splits back to the textual format. +renderSplitFocus :: Focus -> Text +renderSplitFocus Unfocused = "*" +renderSplitFocus (NetworkFocus x) = x <> ":" +renderSplitFocus (ChannelFocus x y) = x <> ":" <> idText y + +-- | When tab completing the first parameter of the focus command +-- the current networks are used. +tabFocus :: Bool -> ClientCommand String +tabFocus isReversed st _ = + simpleTabCompletion plainWordCompleteMode [] completions isReversed st + where + networks = map mkId $ HashMap.keys $ view clientConnections st + params = words $ uncurry take $ clientLine st + + completions = + case params of + [_cmd,_net] -> networks + [_cmd,net,_chan] -> channelWindowsOnNetwork (Text.pack net) st + _ -> [] + +-- | @/channel@ command. Takes a channel or nickname and switches +-- focus to that target on the current network. +cmdChannel :: ClientCommand String +cmdChannel st channel = + case parseFocus (views clientFocus focusNetwork st) channel of + Just focus -> commandSuccess (changeFocus focus st) + Nothing -> commandFailureMsg "No current network" st + +-- | Tab completion for @/channel@. Tab completion uses pre-existing +-- windows. +tabChannel :: + Bool {- ^ reversed order -} -> + ClientCommand String +tabChannel isReversed st _ = + simpleTabCompletion plainWordCompleteMode [] completions isReversed st + where + completions = currentNet <> allWindows + allWindows = renderSplitFocus <$> views clientWindows Map.keys st + currentNet = case views clientFocus focusNetwork st of + Just net -> idText <$> channelWindowsOnNetwork net st + Nothing -> [] + +-- | Return the list of identifiers for open channel windows on +-- the given network name. +channelWindowsOnNetwork :: + Text {- ^ network -} -> + ClientState {- ^ client state -} -> + [Identifier] {- ^ open channel windows -} +channelWindowsOnNetwork network st = + [ chan | ChannelFocus net chan <- Map.keys (view clientWindows st) + , net == network ] + +-- | Implementation of @/dump@. Writes detailed contents of focused buffer +-- to the given filename. +cmdDump :: ClientCommand String +cmdDump st fp = + do res <- try (LText.writeFile fp (LText.unlines outputLines)) + case res of + Left e -> commandFailureMsg (Text.pack (displayException (e :: SomeException))) st + Right{} -> commandSuccess st + + where + focus = view clientFocus st + msgs = preview (clientWindows . ix focus . winMessages) st + outputLines = + case msgs of + Nothing -> [] + Just wls -> convert [] wls + convert acc Nil = acc + convert acc (wl :- wls) = convert (views wlFullImage imageText wl : acc) wls diff --git a/src/Client/Commands/ZNC.hs b/src/Client/Commands/ZNC.hs new file mode 100644 --- /dev/null +++ b/src/Client/Commands/ZNC.hs @@ -0,0 +1,101 @@ +{-# Language OverloadedStrings #-} +{-| +Module : Client.Commands.ZNC +Description : ZNC command implementations +Copyright : (c) Eric Mertens, 2016-2020 +License : ISC +Maintainer : emertens@gmail.com +-} + +module Client.Commands.ZNC (zncCommands) where + +import Control.Applicative +import Client.Commands.Arguments.Spec +import Client.Commands.TabCompletion +import Client.Commands.Types +import Client.State.Network (sendMsg) +import Data.Foldable (asum) +import qualified Data.Text as Text +import Data.Time +import Irc.Commands +import Control.Lens +import LensUtils (localTimeDay, localTimeTimeOfDay, zonedTimeLocalTime) + +zncCommands :: CommandSection +zncCommands = CommandSection "ZNC Support" + + [ Command + (pure "znc") + (remainingArg "arguments") + "Send command directly to ZNC.\n\ + \\n\ + \The advantage of this over /msg is that responses are not broadcast to call clients.\n" + $ NetworkCommand cmdZnc simpleNetworkTab + + , Command + (pure "znc-playback") + (optionalArg (liftA2 (,) (simpleToken "[time]") (optionalArg (simpleToken "[date]")))) + "Request playback from the ZNC 'playback' module.\n\ + \\n\ + \\^Btime\^B determines the time to playback since.\n\ + \\^Bdate\^B determines the date to playback since.\n\ + \\n\ + \When both \^Btime\^B and \^Bdate\^B are omitted, all playback is requested.\n\ + \When both \^Bdate\^B is omitted it is defaulted the most recent date in the past that makes sense.\n\ + \\n\ + \Time format: HOURS:MINUTES (example: 7:00)\n\ + \Date format: YEAR-MONTH-DAY (example: 2016-06-16)\n\ + \\n\ + \Note that the playback module is not installed in ZNC by default!\n" + $ NetworkCommand cmdZncPlayback noNetworkTab + + ] + +cmdZnc :: NetworkCommand String +cmdZnc cs st rest = + do sendMsg cs (ircZnc (Text.words (Text.pack rest))) + commandSuccess st + +cmdZncPlayback :: NetworkCommand (Maybe (String, Maybe String)) +cmdZncPlayback cs st args = + case args of + + -- request everything + Nothing -> success "0" + + -- current date explicit time + Just (timeStr, Nothing) + | Just tod <- parseFormats timeFormats timeStr -> + do now <- getZonedTime + let (nowTod,t) = (zonedTimeLocalTime . localTimeTimeOfDay <<.~ tod) now + yesterday = over (zonedTimeLocalTime . localTimeDay) (addDays (-1)) + fixDay + | tod <= nowTod = id + | otherwise = yesterday + successZoned (fixDay t) + + -- explicit date and time + Just (dateStr, Just timeStr) + | Just day <- parseFormats dateFormats dateStr + , Just tod <- parseFormats timeFormats timeStr -> + do tz <- getCurrentTimeZone + successZoned ZonedTime + { zonedTimeZone = tz + , zonedTimeToLocalTime = LocalTime + { localTimeOfDay = tod + , localDay = day } } + + _ -> commandFailureMsg "unable to parse date/time arguments" st + + where + -- %k doesn't require a leading 0 for times before 10AM + timeFormats = ["%k:%M:%S","%k:%M"] + dateFormats = ["%F"] + parseFormats formats str = + asum (map (parseTimeM False defaultTimeLocale ?? str) formats) + + successZoned = success . formatTime defaultTimeLocale "%s" + + success start = + do sendMsg cs (ircZnc ["*playback", "play", "*", Text.pack start]) + commandSuccess st diff --git a/src/Client/Configuration.hs b/src/Client/Configuration.hs --- a/src/Client/Configuration.hs +++ b/src/Client/Configuration.hs @@ -232,7 +232,6 @@ IO (Either ConfigurationFailure (FilePath, Configuration)) loadConfiguration mbPath = try $ do (path,txt) <- readConfigurationFile mbPath - def <- loadDefaultServerSettings home <- getHomeDirectory rawcfg <- @@ -245,7 +244,7 @@ $ ConfigurationMalformed path $ displayException e Right cfg -> - do cfg' <- resolvePaths path (cfg def home) + do cfg' <- resolvePaths path (cfg defaultServerSettings home) >>= validateDirectories path return (path, cfg') @@ -257,7 +256,7 @@ let resolveServerFilePaths = over (ssTlsClientCert . mapped) res . over (ssTlsClientKey . mapped) res . over (ssTlsServerCert . mapped) res - . over (ssSaslEcdsaFile . mapped) res + . over (ssSaslMechanism . mapped . _SaslEcdsa . _3) res . over (ssLogDir . mapped) res return $! over (configExtensions . mapped . extensionPath) res . over (configServers . mapped) resolveServerFilePaths diff --git a/src/Client/Configuration/ServerSettings.hs b/src/Client/Configuration/ServerSettings.hs --- a/src/Client/Configuration/ServerSettings.hs +++ b/src/Client/Configuration/ServerSettings.hs @@ -25,14 +25,13 @@ , ssUser , ssReal , ssPassword - , ssSaslUsername - , ssSaslPassword - , ssSaslEcdsaFile + , ssSaslMechanism , ssHostName , ssPort , ssTls , ssTlsClientCert , ssTlsClientKey + , ssTlsClientKeyPassword , ssTlsServerCert , ssTlsCiphers , ssConnectCmds @@ -48,16 +47,27 @@ , ssAutoconnect , ssNickCompletion , ssLogDir - , ssProtocolFamily + , ssBindHostName , ssSts , ssTlsPubkeyFingerprint , ssTlsCertFingerprint , ssShowAccounts , ssCapabilities - -- * Load function - , loadDefaultServerSettings + -- * SASL Mechanisms + , SaslMechanism(..) + , _SaslExternal + , _SaslEcdsa + , _SaslPlain + -- * Secrets + , Secret(..) + , SecretException(..) + , loadSecrets + + -- * Defaults + , defaultServerSettings + -- * TLS settings , UseTls(..) , Fingerprint(..) @@ -71,20 +81,23 @@ import Client.Commands.WordCompletion import Client.Configuration.Macros (macroCommandSpec) import Config.Schema.Spec +import Control.Exception (Exception, displayException, throwIO, try) import Control.Lens +import Control.Monad ((>=>)) import qualified Data.ByteString as B import Data.Functor.Alt (()) import Data.List.NonEmpty (NonEmpty((:|))) import Data.ByteString (ByteString) -import Data.Maybe (fromMaybe) import Data.Monoid import Data.Text (Text) +import qualified Data.List.NonEmpty as NonEmpty import Data.List.Split (chunksOf, splitOn) import qualified Data.Text as Text import Irc.Identifier (Identifier, mkId) -import Network.Socket (HostName, PortNumber, Family(..)) +import Network.Socket (HostName, PortNumber) import Numeric (readHex) -import System.Environment +import qualified System.Exit as Exit +import qualified System.Process as Process import Text.Regex.TDFA import Text.Regex.TDFA.Text (compile) @@ -93,15 +106,14 @@ { _ssNicks :: !(NonEmpty Text) -- ^ connection nicknames , _ssUser :: !Text -- ^ connection username , _ssReal :: !Text -- ^ connection realname / GECOS - , _ssPassword :: !(Maybe Text) -- ^ server password - , _ssSaslUsername :: !(Maybe Text) -- ^ SASL username - , _ssSaslPassword :: !(Maybe Text) -- ^ SASL plain password - , _ssSaslEcdsaFile :: !(Maybe FilePath) -- ^ SASL ecdsa private key + , _ssPassword :: !(Maybe Secret) -- ^ server password + , _ssSaslMechanism :: !(Maybe SaslMechanism) -- ^ SASL mechanism , _ssHostName :: !HostName -- ^ server hostname , _ssPort :: !(Maybe PortNumber) -- ^ server port , _ssTls :: !UseTls -- ^ use TLS to connect , _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 , _ssConnectCmds :: ![[ExpansionChunk]] -- ^ commands to execute upon successful connection @@ -117,7 +129,7 @@ , _ssAutoconnect :: !Bool -- ^ Connect to this network on server startup , _ssNickCompletion :: WordCompletionMode -- ^ Nick completion mode for this server , _ssLogDir :: Maybe FilePath -- ^ Directory to save logs of chat - , _ssProtocolFamily :: Maybe Family -- ^ Protocol family to connect with + , _ssBindHostName :: Maybe HostName -- ^ Local bind host , _ssSts :: !Bool -- ^ Honor STS policies when true , _ssTlsPubkeyFingerprint :: !(Maybe Fingerprint) -- ^ optional acceptable public key fingerprint , _ssTlsCertFingerprint :: !(Maybe Fingerprint) -- ^ optional acceptable certificate fingerprint @@ -126,6 +138,18 @@ } deriving Show +data Secret + = SecretText Text -- ^ Constant text + | SecretCommand (NonEmpty Text) -- ^ Command to generate text + deriving Show + +-- | SASL mechanisms and configuration data. +data SaslMechanism + = 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 + deriving Show + -- | Regular expression matched with original source to help with debugging. data KnownRegex = KnownRegex Text Regex @@ -153,28 +177,23 @@ deriving Show makeLenses ''ServerSettings +makePrisms ''SaslMechanism --- | Load the defaults for server settings based on the environment --- variables. --- --- Environment variables @USER@, @IRCPASSSWORD@, and @SASLPASSWORD@ are used. -loadDefaultServerSettings :: IO ServerSettings -loadDefaultServerSettings = - do env <- getEnvironment - let username = Text.pack (fromMaybe "guest" (lookup "USER" env)) - return ServerSettings - { _ssNicks = pure username - , _ssUser = username - , _ssReal = username - , _ssPassword = Text.pack <$> lookup "IRCPASSWORD" env - , _ssSaslUsername = Nothing - , _ssSaslPassword = Text.pack <$> lookup "SASLPASSWORD" env - , _ssSaslEcdsaFile = Nothing +-- | The defaults for server settings. +defaultServerSettings :: ServerSettings +defaultServerSettings = + ServerSettings + { _ssNicks = pure "guest" + , _ssUser = "username" + , _ssReal = "realname" + , _ssPassword = Nothing + , _ssSaslMechanism = Nothing , _ssHostName = "" , _ssPort = Nothing , _ssTls = UseInsecure , _ssTlsClientCert = Nothing , _ssTlsClientKey = Nothing + , _ssTlsClientKeyPassword = Nothing , _ssTlsServerCert = Nothing , _ssTlsCiphers = "HIGH" , _ssConnectCmds = [] @@ -190,7 +209,7 @@ , _ssAutoconnect = False , _ssNickCompletion = defaultNickWordCompleteMode , _ssLogDir = Nothing - , _ssProtocolFamily = Nothing + , _ssBindHostName = Nothing , _ssSts = True , _ssTlsPubkeyFingerprint = Nothing , _ssTlsCertFingerprint = Nothing @@ -238,14 +257,8 @@ , req "realname" ssReal anySpec "\"GECOS\" name sent to server visible in /whois" - , opt "sasl-username" ssSaslUsername anySpec - "Username for SASL authentication to NickServ" - - , opt "sasl-password" ssSaslPassword anySpec - "Password for SASL authentication to NickServ" - - , opt "sasl-ecdsa-key" ssSaslEcdsaFile stringSpec - "Path to ECDSA key for non-password SASL authentication" + , opt "sasl" ssSaslMechanism saslMechanismSpec + "SASL settings" , req "tls" ssTls useTlsSpec "Set to `yes` to enable secure connect. Set to `yes-insecure` to disable certificate checking." @@ -256,6 +269,9 @@ , opt "tls-client-key" ssTlsClientKey stringSpec "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 "Path to CA certificate bundle" @@ -298,8 +314,8 @@ , opt "log-dir" ssLogDir stringSpec "Path to log file directory for this server" - , opt "protocol-family" ssProtocolFamily protocolFamilySpec - "IP protocol family to use for this connection" + , opt "bind-hostname" ssBindHostName stringSpec + "Source address to bind to before connecting" , req "sts" ssSts yesOrNoSpec "Honor server STS policies forcing TLS connections" @@ -317,6 +333,28 @@ "Extra capabilities to unconditionally request from the server" ] +saslMechanismSpec :: ValueSpec SaslMechanism +saslMechanismSpec = plain external ecdsa + where + mech m = reqSection' "mechanism" (atomSpec m) "Mechanism" + authzid = optSection "authzid" "Authorization identity" + username = reqSection "username" "Authentication identity" + + plain = + sectionsSpec "sasl-plain" $ SaslPlain <$ + optSection' "mechanism" (atomSpec "plain") "Mechanism" <*> + authzid <*> username <*> reqSection "password" "Password" + + external = + sectionsSpec "sasl-external" $ SaslExternal <$ mech "external" <*> + authzid + + ecdsa = + sectionsSpec "sasl-ecdsa-nist256p-challenge-mech" $ + SaslEcdsa <$ mech "ecdsa-nist256p-challenge" <*> + authzid <*> username <*> + reqSection' "private-key" stringSpec "Private key file" + hookSpec :: ValueSpec HookConfig hookSpec = flip HookConfig [] <$> anySpec @@ -352,17 +390,9 @@ | ':' `elem` str = splitOn ":" str | otherwise = chunksOf 2 str --- | Specification for IP protocol family. -protocolFamilySpec :: ValueSpec Family -protocolFamilySpec = - AF_INET <$ atomSpec "inet" - AF_INET6 <$ atomSpec "inet6" - - nicksSpec :: ValueSpec (NonEmpty Text) nicksSpec = oneOrNonemptySpec anySpec - useTlsSpec :: ValueSpec UseTls useTlsSpec = UseTls <$ atomSpec "yes" @@ -384,3 +414,31 @@ case compile defaultCompOpt ExecOption{captureGroups = False} str of Left e -> Left (Text.pack e) Right r -> Right (KnownRegex str r) + +instance HasSpec Secret where + anySpec = SecretText <$> textSpec + SecretCommand <$> sectionsSpec "command" (reqSection "command" "Command and arguments to execute to secret") + +data SecretException = SecretException String String + deriving Show + +instance Exception SecretException + +-- | Run the secret commands in a server configuration replacing them with secret text. +-- Throws 'SecretException' +loadSecrets :: ServerSettings -> IO ServerSettings +loadSecrets = + traverseOf (ssPassword . _Just ) (loadSecret "server password") >=> + traverseOf (ssSaslMechanism . _Just . _SaslPlain . _3) (loadSecret "SASL password") >=> + traverseOf (ssTlsClientKeyPassword . _Just ) (loadSecret "TLS key password") + +-- | Run a command if found and replace it with the first line of stdout result. +loadSecret :: String -> Secret -> IO Secret +loadSecret _ (SecretText txt) = pure (SecretText txt) +loadSecret label (SecretCommand (cmd NonEmpty.:| args)) = + do let u = Text.unpack + res <- try (Process.readProcessWithExitCode (u cmd) (map u args) "") + case res of + Right (Exit.ExitSuccess,out,_) -> pure (SecretText (Text.pack (takeWhile ('\n' /=) out))) + Right (Exit.ExitFailure{},_,err) -> throwIO (SecretException label err) + Left ioe -> throwIO (SecretException label (displayException (ioe::IOError))) diff --git a/src/Client/EventLoop/Network.hs b/src/Client/EventLoop/Network.hs --- a/src/Client/EventLoop/Network.hs +++ b/src/Client/EventLoop/Network.hs @@ -125,12 +125,8 @@ ClientState {- ^ client state -} -> IO ClientState processSaslEcdsa now challenge cs st = - case view ssSaslEcdsaFile ss of - Nothing -> - do sendMsg cs ircCapEnd - return $! recordError now (view csNetwork cs) "panic: ecdsatool malformed output" st - - Just path -> + case view ssSaslMechanism ss of + Just (SaslEcdsa _ _ path) -> do res <- Ecdsa.computeResponse path challenge case res of Left e -> @@ -139,6 +135,10 @@ Right resp -> do sendMsg cs (ircAuthenticate resp) return $! set asLens AS_None st + + _ -> + do sendMsg cs ircCapEnd + return $! recordError now (view csNetwork cs) "panic: ecdsa mechanism not configured" st where ss = view csSettings cs asLens = clientConnection (view csNetwork cs) . csAuthenticationState diff --git a/src/Client/Hook/FreRelay.hs b/src/Client/Hook/FreRelay.hs --- a/src/Client/Hook/FreRelay.hs +++ b/src/Client/Hook/FreRelay.hs @@ -126,6 +126,7 @@ (UserInfo (mkId (nick <> "@" <> srv)) user host) chan "" -- account + "" -- gecos partMsg :: Identifier {- ^ channel -} -> diff --git a/src/Client/Hook/Znc/Buffextras.hs b/src/Client/Hook/Znc/Buffextras.hs --- a/src/Client/Hook/Znc/Buffextras.hs +++ b/src/Client/Hook/Znc/Buffextras.hs @@ -54,7 +54,7 @@ prefixedParser chan = do pfx <- prefixParser choice - [ Join pfx chan "" <$ skipToken "joined" + [ 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 diff --git a/src/Client/Image/Layout.hs b/src/Client/Image/Layout.hs --- a/src/Client/Image/Layout.hs +++ b/src/Client/Image/Layout.hs @@ -35,7 +35,7 @@ -- | Layout algorithm for all windows in a single column. drawLayoutOne :: ClientState {- ^ client state -} -> - [Focus] {- ^ extra window names -} -> + [(Focus, Subfocus)] {- ^ extra windows -} -> (Int, Int, Int, Image) {- ^ overscroll and final image -} drawLayoutOne st extrafocus = (overscroll, pos, nextOffset, output) @@ -49,21 +49,21 @@ output = vertCat $ reverse $ main - : [ drawExtra st w h' foc imgs - | (h', (foc, imgs)) <- zip hs extraLines] + : [ drawExtra st w h' foc subfoc imgs + | (h', (foc, subfoc, imgs)) <- zip hs extraLines] rows = view clientHeight st -- don't count textbox or the main status line against the main window's height saveRows = 1 + imageHeight (statusLineImage w st) - extraLines = [ (focus', viewLines focus' FocusMessages w st) - | focus' <- extrafocus ] + extraLines = [ (focus, subfocus, viewLines focus subfocus w st) + | (focus, subfocus) <- extrafocus ] -- | Layout algorithm for all windows in a single column. drawLayoutTwo :: ClientState {- ^ client state -} -> - [Focus] {- ^ extra window names -} -> + [(Focus, Subfocus)] {- ^ extra windows -} -> (Int, Int, Int, Image) {- ^ overscroll, cursor pos, offset, final image -} drawLayoutTwo st extrafocus = (overscroll, pos, nextOffset, output) @@ -75,8 +75,8 @@ output = main <|> divider <|> extraImgs extraImgs = vertCat $ reverse - [ drawExtra st wr h' foc imgs - | (h', (foc, imgs)) <- zip hs extraLines] + [ drawExtra st wr h' foc subfoc imgs + | (h', (foc, subfoc, imgs)) <- zip hs extraLines] (overscroll, pos, nextOffset, main) = drawMain wl rows scroll st @@ -85,8 +85,8 @@ divider = charFill (view palWindowDivider pal) ' ' 1 rows rows = view clientHeight st - extraLines = [ (focus', viewLines focus' FocusMessages wr st) - | focus' <- extrafocus ] + extraLines = [ (focus, subfocus, viewLines focus subfocus wr st) + | (focus, subfocus) <- extrafocus ] drawMain :: Int {- ^ draw width -} -> @@ -115,10 +115,11 @@ Int {- ^ draw width -} -> Int {- ^ draw height -} -> Focus {- ^ focus -} -> + Subfocus {- ^ subfocus -} -> [Image'] {- ^ image lines -} -> Image {- ^ rendered window -} -drawExtra st w h focus lineImages = - msgImg <-> unpackImage (minorStatusLineImage focus w True st) +drawExtra st w h focus subfocus lineImages = + msgImg <-> unpackImage (minorStatusLineImage focus subfocus w True st) where (_, msgImg) = messagePane w h 0 lineImages diff --git a/src/Client/Image/Message.hs b/src/Client/Image/Message.hs --- a/src/Client/Image/Message.hs +++ b/src/Client/Image/Message.hs @@ -41,7 +41,6 @@ import Data.Char import Data.Hashable (hash) import Data.HashMap.Strict (HashMap) -import qualified Data.HashMap.Strict as HashMap import Data.HashSet (HashSet) import qualified Data.HashSet as HashSet import Data.List @@ -64,7 +63,7 @@ , rendNicks :: HashSet Identifier -- ^ nicknames to highlight , rendMyNicks :: HashSet Identifier -- ^ nicknames to highlight in red , rendPalette :: Palette -- ^ nick color palette - , rendAccounts :: HashMap Identifier UserAndHost + , rendAccounts :: Maybe (HashMap Identifier UserAndHost) } -- | Default 'MessageRendererParams' with no sigils or nicknames specified @@ -75,7 +74,7 @@ , rendNicks = HashSet.empty , rendMyNicks = HashSet.empty , rendPalette = defaultPalette - , rendAccounts = HashMap.empty + , rendAccounts = Nothing } @@ -215,11 +214,19 @@ who n = string (view palSigil pal) sigils <> ui where baseUI = coloredUserInfo pal rm myNicks n - ui = case rendAccounts rp ^? ix (userNick n) . uhAccount of - Just acct - | Text.null acct -> "~" <> baseUI - | mkId acct /= userNick n -> baseUI <> "(" <> text' defAttr (cleanText acct) <> ")" - _ -> baseUI + 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) + . uhAccount + . filtered isKnown in + case mbAcct of + Just acct + | mkId acct == userNick n -> baseUI + | otherwise -> baseUI <> "(" <> text' defAttr (cleanText acct) <> ")" + Nothing -> "~" <> baseUI in case body of Join {} -> mempty @@ -342,7 +349,7 @@ -- nick!user@host plainWho n <> - case rendAccounts rp ^? ix (userNick n) . uhAccount of + case rendAccounts rp ^? folded . ix (userNick n) . uhAccount of Just acct | not (Text.null acct) -> text' quietAttr ("(" <> cleanText acct <> ")") _ -> "" @@ -354,12 +361,17 @@ " is now known as " <> coloredIdentifier pal NormalIdentifier myNicks new - Join nick _chan acct -> + Join nick _chan acct gecos -> string quietAttr "join " <> plainWho nick <> - if Text.null acct - then mempty - else text' quietAttr ("(" <> cleanText acct <> ")") + accountPart <> gecosPart + where + accountPart + | Text.null acct = mempty + | otherwise = text' quietAttr ("(" <> cleanText acct <> ")") + gecosPart + | Text.null gecos = mempty + | otherwise = text' quietAttr (" [" <> cleanText gecos <> "]") Part nick _chan mbreason -> string quietAttr "part " <> diff --git a/src/Client/Image/StatusLine.hs b/src/Client/Image/StatusLine.hs --- a/src/Client/Image/StatusLine.hs +++ b/src/Client/Image/StatusLine.hs @@ -52,7 +52,7 @@ myNickImage st : map unpackImage [ focusImage (view clientFocus st) st - , subfocusImage st + , subfocusImage (view clientSubfocus st) st , detailImage st , nometaImage (view clientFocus st) st , scrollImage st @@ -86,15 +86,17 @@ -- | The minor status line is used when rendering the @/splits@ and -- @/mentions@ views to show the associated window name. minorStatusLineImage :: - Focus {- ^ window name -} -> - Int {- ^ draw width -} -> - Bool {- ^ show hidemeta status -} -> + Focus {- ^ window name -} -> + Subfocus {- ^ subfocus -} -> + Int {- ^ draw width -} -> + Bool {- ^ show hidemeta status -} -> ClientState {- ^ client state -} -> Image' -minorStatusLineImage focus w showHideMeta st = +minorStatusLineImage focus subfocus w showHideMeta st = content <> mconcat (replicate fillSize bar) where content = focusImage focus st <> + subfocusImage subfocus st <> if showHideMeta then nometaImage focus st else mempty fillSize = max 0 (w - imageWidth content) @@ -113,10 +115,9 @@ -- | Indicate when the client is potentially showing a subset of the -- available chat messages. filterImage :: ClientState -> Image' -filterImage st = - case clientMatcher st of - Nothing -> mempty - Just {} -> infoBubble (string attr "filtered") +filterImage st + | clientIsFiltered st = infoBubble (string attr "filtered") + | otherwise = mempty where pal = clientPalette st attr = view palError pal @@ -306,11 +307,10 @@ modeImage m = char (fromMaybe defAttr (view (at m) pal)) m -subfocusImage :: ClientState -> Image' -subfocusImage st = foldMap infoBubble (viewSubfocusLabel pal subfocus) +subfocusImage :: Subfocus -> ClientState -> Image' +subfocusImage subfocus st = foldMap infoBubble (viewSubfocusLabel pal subfocus) where pal = clientPalette st - subfocus = view clientSubfocus st focusImage :: Focus -> ClientState -> Image' focusImage focus st = infoBubble $ mconcat diff --git a/src/Client/Message.hs b/src/Client/Message.hs --- a/src/Client/Message.hs +++ b/src/Client/Message.hs @@ -87,7 +87,7 @@ ircSummary :: IrcMsg -> IrcSummary ircSummary msg = case msg of - Join who _ _ -> JoinSummary (userNick who) + Join who _ _ _ -> JoinSummary (userNick who) Part who _ _ -> PartSummary (userNick who) Quit who _ -> QuitSummary (userNick who) Nick who who' -> NickSummary (userNick who) who' diff --git a/src/Client/Network/Connect.hs b/src/Client/Network/Connect.hs --- a/src/Client/Network/Connect.hs +++ b/src/Client/Network/Connect.hs @@ -23,22 +23,27 @@ import Control.Applicative import Control.Exception (bracket) import Control.Lens -import Network.Socket (PortNumber) +import qualified Data.Text.Encoding as Text +import Network.Socket (PortNumber) import Hookup buildConnectionParams :: ServerSettings -> ConnectionParams buildConnectionParams args = - let tlsParams = TlsParams - (view ssTlsClientCert args) - (view ssTlsClientKey args <|> view ssTlsClientCert args) - (view ssTlsServerCert args) - (view ssTlsCiphers args) - family = - case view ssProtocolFamily args of - Nothing -> defaultFamily - Just pf -> pf + let tlsParams insecure = TlsParams + { tpClientCertificate = view ssTlsClientCert args + , tpClientPrivateKey = view ssTlsClientKey args <|> view ssTlsClientCert args + , tpClientPrivateKeyPassword = privateKeyPassword + , tpServerCertificate = view ssTlsServerCert args + , tpCipherSuite = view ssTlsCiphers args + , tpInsecure = insecure + } + privateKeyPassword = + case view ssTlsClientKeyPassword args of + Just (SecretText str) -> PwBS (Text.encodeUtf8 str) + _ -> PwNone + useSecure = case view ssTls args of UseInsecure -> Nothing @@ -51,11 +56,11 @@ (view ssSocksPort args) in ConnectionParams - { cpFamily = family - , cpHost = view ssHostName args + { cpHost = view ssHostName args , cpPort = ircPort args , cpTls = useSecure , cpSocks = proxySettings + , cpBind = view ssBindHostName args } diff --git a/src/Client/Options.hs b/src/Client/Options.hs --- a/src/Client/Options.hs +++ b/src/Client/Options.hs @@ -126,18 +126,18 @@ print (generateDocs configurationSpec) helpTxt :: String -helpTxt = usageInfo "glirc2 [FLAGS] INITIAL_NETWORKS..." options +helpTxt = usageInfo "glirc [FLAGS] INITIAL_NETWORKS..." options tryHelpTxt :: String tryHelpTxt = - "Run 'glirc2 --help' to see a list of available command line options." + "Run 'glirc --help' to see a list of available command line options." -- version information --------------------------------------------- versionTxt :: String versionTxt = unlines [ "glirc-" ++ showVersion version ++ gitHashTxt ++ gitDirtyTxt - , "Copyright 2016 Eric Mertens" + , "Copyright 2016-2020 Eric Mertens" ] fullVersionTxt :: String diff --git a/src/Client/State.hs b/src/Client/State.hs --- a/src/Client/State.hs +++ b/src/Client/State.hs @@ -50,7 +50,9 @@ -- * Client operations , withClientState - , clientMatcher, Matcher(..), buildMatcher + , clientIsFiltered + , clientFilter + , buildMatcher , clientToggleHideMeta , clientHighlightsNetwork , channelUserList @@ -124,6 +126,7 @@ import Client.State.Network import Client.State.Window import Client.State.DCC +import ContextFilter import Control.Applicative import Control.Concurrent.MVar import Control.Concurrent.STM @@ -153,6 +156,7 @@ import Irc.UserInfo import LensUtils import RtsStats (Stats) +import qualified System.Random.MWC as Random import Text.Regex.TDFA import Text.Regex.TDFA.String (compile) @@ -164,7 +168,7 @@ , _clientActivityReturn :: !(Maybe Focus) -- ^ focus prior to jumping to activity , _clientFocus :: !Focus -- ^ currently focused buffer , _clientSubfocus :: !Subfocus -- ^ current view mode - , _clientExtraFocus :: ![Focus] -- ^ extra messages windows to view + , _clientExtraFocus :: ![(Focus, Subfocus)]-- ^ extra messages windows to view , _clientConnections :: !(HashMap Text NetworkState) -- ^ state of active connections , _clientEvents :: !(TQueue NetworkEvent) -- ^ incoming network event queue @@ -337,8 +341,8 @@ accounts = if view (csSettings . ssShowAccounts) cs - then view csUsers cs - else HashMap.empty + then Just (view csUsers cs) + else Nothing recordLogLine :: @@ -592,16 +596,15 @@ -- | Mark the messages on the current window (and any splits) as seen. markSeen :: ClientState -> ClientState -markSeen st = - case view clientSubfocus st of - FocusMessages -> foldl' aux st focuses - _ -> st +markSeen st = foldl' aux st messageFocuses where aux acc focus = overStrict (clientWindows . ix focus) windowSeen acc - focuses = view clientFocus st - : view clientExtraFocus st + messageFocuses = [focus | (focus, FocusMessages) <- allFocuses] + allFocuses = (view clientFocus st, view clientSubfocus st) + : view clientExtraFocus st + -- | Add the textbox input to the edit history and clear the textbox. consumeInput :: ClientState -> ClientState consumeInput = over clientTextBox Edit.success @@ -650,31 +653,63 @@ Nothing -> Nothing Just r -> Just r +clientIsFiltered :: ClientState -> Bool +clientIsFiltered = isJust . clientMatcher + +clientFilter :: ClientState -> (a -> LText.Text) -> [a] -> [a] +clientFilter st f xs = + case clientMatcher st of + Nothing -> xs + Just m -> + filterContext + (matcherBefore m) + (matcherAfter m) + (matcherPred m . f) + xs + +data MatcherArgs = MatcherArgs + { argAfter :: !Int + , argBefore :: !Int + , argInvert :: !Bool + , argSensitive :: !Bool + } + +defaultMatcherArgs :: MatcherArgs +defaultMatcherArgs = MatcherArgs + { argAfter = 0 + , argBefore = 0 + , argInvert = False + , argSensitive = True + } + buildMatcher :: String -> Maybe Matcher -buildMatcher = go (True, 0, 0) +buildMatcher = go defaultMatcherArgs where - go (sensitive, b, a) reStr = + go !args reStr = case dropWhile (' '==) reStr of - '-' : 'i' : ' ' : reStr' -> go (False, b, a) reStr' - '-' : 'A' : reStr' | [(a' , ' ':reStr'')] <- reads reStr', a' >= 0 -> go (sensitive, b, a') reStr'' - '-' : 'B' : reStr' | [(b' , ' ':reStr'')] <- reads reStr', b' >= 0 -> go (sensitive, b', a) reStr'' - '-' : 'C' : reStr' | [(num, ' ':reStr'')] <- reads reStr', num >= 0 -> go (sensitive, num, num) reStr'' - '-' : '-' : reStr' -> finish (sensitive, b, a) (drop 1 reStr') - _ -> finish (sensitive, b, a) reStr + '-' : 'i' : ' ' : reStr' -> go args{argSensitive=False} reStr' + '-' : 'v' : ' ' : reStr' -> go args{argInvert=True} reStr' + '-' : 'A' : reStr' | [(a,' ':reStr'')] <- reads reStr', a>=0 -> go args{argAfter=a} reStr'' + '-' : 'B' : reStr' | [(b,' ':reStr'')] <- reads reStr', b>=0 -> go args{argBefore=b} reStr'' + '-' : 'C' : reStr' | [(c,' ':reStr'')] <- reads reStr', c>=0 -> go args{argAfter=c,argBefore=c} reStr'' + '-' : '-' : ' ' : reStr' -> finish args reStr' + _ -> finish args reStr - finish (sensitive, b, a) reStr = - case compile defaultCompOpt{caseSensitive=sensitive} + finish args reStr = + case compile defaultCompOpt{caseSensitive=argSensitive args} defaultExecOpt{captureGroups=False} reStr of Left{} -> Nothing - Right r -> Just (Matcher b a (matchTest r . LText.unpack)) + Right r + | argInvert args -> Just (Matcher (argBefore args) (argAfter args) (not . matchTest r . LText.unpack)) + | otherwise -> Just (Matcher (argBefore args) (argAfter args) ( matchTest r . LText.unpack)) -- | Compute the command and arguments currently in the textbox. clientActiveCommand :: ClientState {- ^ client state -} -> Maybe (String,String) {- ^ command name and argument string -} clientActiveCommand st = - case break (==' ') (clientFirstLine st) of + case break (==' ') (dropWhile (' '==) (clientFirstLine st)) of ('/':cmd,_:args) -> Just (cmd,args) _ -> Nothing @@ -729,10 +764,31 @@ , _ssHostName = Text.unpack network } - settings = fromMaybe defSettings - $ preview (clientConfig . configServers . ix network) st + eSettings0 <- + try $ + loadSecrets $ + fromMaybe defSettings $ + preview (clientConfig . configServers . ix network) st - now <- getCurrentTime + case eSettings0 of + Left (SecretException label err) -> + do now <- getZonedTime + let txt = "Failed loading secret \x02" <> label <> "\x02: " <> err + pure $! recordError now network (Text.pack txt) st + + Right settings0 -> + do settings1 <- applyStsPolicy stsUpgrade settings0 st + -- don't bother delaying on the first reconnect + let delay = 15 * max 0 (attempts - 1) + c <- createConnection delay settings1 + seed <- Random.withSystemRandom (Random.asGenIO Random.save) + let cs = newNetworkState network settings1 c (PingConnecting attempts lastTime) seed + traverse_ (sendMsg cs) (initialMessages cs) + pure (set (clientConnections . at network) (Just cs) st) + +applyStsPolicy :: Maybe Int -> ServerSettings -> ClientState -> IO ServerSettings +applyStsPolicy stsUpgrade settings st = + do now <- getCurrentTime let stsUpgrade' | Just{} <- stsUpgrade = stsUpgrade | UseInsecure <- view ssTls settings @@ -741,26 +797,10 @@ , now < view stsExpiration policy = Just (view stsPort policy) | otherwise = Nothing - - settings1 = - case stsUpgrade' of - Just port -> set ssPort (Just (fromIntegral port)) - $ set ssTls UseTls settings - Nothing -> settings - - - -- don't bother delaying on the first reconnect - delay = 15 * max 0 (attempts - 1) - - c <- createConnection - delay - settings1 - - let cs = newNetworkState network settings1 c (PingConnecting attempts lastTime) - traverse_ (sendMsg cs) (initialMessages cs) - - return $ set (clientConnections . at network) (Just cs) st - + pure $ case stsUpgrade' of + Just port -> set ssPort (Just (fromIntegral port)) + $ set ssTls UseTls settings + Nothing -> settings applyMessageToClientState :: ZonedTime {- ^ timestamp -} -> @@ -832,12 +872,11 @@ -- | List of extra focuses to display as split windows -clientExtraFocuses :: ClientState -> [Focus] +clientExtraFocuses :: ClientState -> [(Focus, Subfocus)] clientExtraFocuses st = - case view clientSubfocus st of - FocusMessages -> view clientFocus st `delete` view clientExtraFocus st - _ -> [] - + delete + (view clientFocus st, view clientSubfocus st) + (view clientExtraFocus st) ------------------------------------------------------------------------ -- Focus Management @@ -899,21 +938,26 @@ -- Don't deactivate a window if it's going to stay active deactivatePrevious - | oldFocus `elem` focus : view clientExtraFocus st = id + | (oldFocus, FocusMessages) `elem` (focus, FocusMessages) : view clientExtraFocus st = id | otherwise = over (clientWindows . ix oldFocus) windowDeactivate -- | Unified logic for assigning to the extra focuses field that activates -- and deactivates windows as needed. -setExtraFocus :: [Focus] -> ClientState -> ClientState +setExtraFocus :: [(Focus, Subfocus)] -> ClientState -> ClientState setExtraFocus newFocuses st = aux windowDeactivate newlyInactive $ aux windowActivate newlyActive $ set clientExtraFocus newFocuses st where - newlyActive = newFocuses \\ (view clientFocus st : view clientExtraFocus st) + messagePart x = [focus | (focus, FocusMessages) <- x] - newlyInactive = view clientExtraFocus st \\ (view clientFocus st : newFocuses) + current = (view clientFocus st, view clientSubfocus st) + + newlyActive = messagePart newFocuses \\ messagePart (current : view clientExtraFocus st) + + newlyInactive = messagePart (view clientExtraFocus st) + \\ messagePart (current : newFocuses) aux f xs st1 = foldl' (\acc w -> overStrict (clientWindows . ix w) f acc) st1 xs diff --git a/src/Client/State/DCC.hs b/src/Client/State/DCC.hs --- a/src/Client/State/DCC.hs +++ b/src/Client/State/DCC.hs @@ -73,8 +73,7 @@ import Irc.Identifier (Identifier, idText) import Irc.Message (IrcMsg(..)) import Irc.UserInfo (UserInfo(..), uiNick) -import Network.Socket ( HostName, PortNumber, Family(..) - , hostAddressToTuple ) +import Network.Socket (HostName, PortNumber, hostAddressToTuple) import System.FilePath ((), takeFileName) import System.IO (withFile, IOMode(..), openFile, hClose, hFileSize) @@ -185,7 +184,7 @@ wait outThread where param = ConnectionParams - { cpFamily = AF_INET + { cpBind = Just "0.0.0.0" -- only support IPv4 , cpHost = from , cpPort = port , cpSocks = Nothing diff --git a/src/Client/State/Network.hs b/src/Client/State/Network.hs --- a/src/Client/State/Network.hs +++ b/src/Client/State/Network.hs @@ -46,6 +46,7 @@ , csCertificate , csMessageHooks , csAuthenticationState + , csSeed -- * Cross-message state , Transaction(..) @@ -81,6 +82,7 @@ import Client.Hook (MessageHook) import Client.Hooks (messageHooks) import Control.Lens +import qualified Control.Monad.ST as ST import Data.HashMap.Strict (HashMap) import qualified Data.HashMap.Strict as HashMap import qualified Data.HashSet as HashSet @@ -105,6 +107,7 @@ import Irc.RawIrcMsg import Irc.UserInfo import LensUtils +import qualified System.Random.MWC as Random -- | State tracked for each IRC connection data NetworkState = NetworkState @@ -131,6 +134,9 @@ , _csPingStatus :: !PingStatus -- ^ state of ping timer , _csLastReceived :: !(Maybe UTCTime) -- ^ time of last message received , _csCertificate :: ![Text] + + -- Randomization + , _csSeed :: Random.Seed } -- | State of the authentication transaction @@ -161,7 +167,6 @@ | NamesTransaction [Text] | BanTransaction [(Text,MaskListEntry)] | WhoTransaction [UserInfo] - | CapTransaction | CapLsTransaction [(Text, Maybe Text)] deriving Show @@ -242,15 +247,16 @@ ServerSettings {- ^ server settings -} -> NetworkConnection {- ^ active network connection -} -> PingStatus {- ^ initial ping status -} -> + Random.Seed {- ^ initial random seed -} -> NetworkState {- ^ new network state -} -newNetworkState network settings sock ping = NetworkState +newNetworkState network settings sock ping seed = NetworkState { _csUserInfo = UserInfo "*" "" "" , _csChannels = HashMap.empty , _csSocket = sock , _csChannelTypes = defaultChannelTypes , _csModeTypes = defaultModeTypes , _csUmodeTypes = defaultUmodeTypes - , _csTransaction = CapTransaction + , _csTransaction = NoTransaction , _csModes = "" , _csSnomask = "" , _csStatusMsg = "" @@ -265,6 +271,7 @@ , _csNextPingTime = Nothing , _csLastReceived = Nothing , _csCertificate = [] + , _csSeed = seed } buildMessageHooks :: [HookConfig] -> [MessageHook] @@ -294,7 +301,7 @@ case msg of Ping args -> ([ircPong args], cs) Pong _ -> noReply $ doPong msgWhen cs - Join user chan acct -> + Join user chan acct _ -> ( reply , recordUser user acct $ overChannel chan (joinChannel (userNick user)) @@ -331,16 +338,22 @@ $ overChannels (nickChange (userNick oldNick) newNick) cs Reply RPL_WELCOME (me:_) -> doWelcome msgWhen (mkId me) cs - Reply RPL_SASLSUCCESS _ -> endCapTransaction cs - Reply RPL_SASLFAIL _ -> endCapTransaction cs + Reply RPL_SASLSUCCESS _ -> ([ircCapEnd], cs) + Reply RPL_SASLFAIL _ -> ([ircCapEnd], cs) + Reply ERR_NICKNAMEINUSE (_:badnick:_) | PingConnecting{} <- view csPingStatus cs -> doBadNick badnick cs + Reply ERR_BANNEDNICK (_:badnick:_) + | PingConnecting{} <- view csPingStatus cs -> doBadNick badnick cs + Reply ERR_ERRONEUSNICKNAME (_:badnick:_) + | PingConnecting{} <- view csPingStatus cs -> doBadNick badnick cs + Reply RPL_HOSTHIDDEN (_:host:_) -> noReply (set (csUserInfo . uiHost) host cs) -- /who <#channel> %tuhna,616 Reply RPL_WHOSPCRPL [_me,"616",user,host,nick,acct] -> - let acct' = if acct == "0" then "" else acct + let acct' = if acct == "0" then "*" else acct in noReply (recordUser (UserInfo (mkId nick) user host) acct' cs) Reply code args -> noReply (doRpl code msgWhen args cs) @@ -377,7 +390,6 @@ . set csNick me . set csNextPingTime (Just $! addUTCTime 30 (zonedTimeToUTC msgWhen)) . set csPingStatus PingNone - . set csTransaction NoTransaction -- wipe out CapTransaction if it was active -- | Handle 'ERR_NICKNAMEINUSE' errors when connecting. doBadNick :: @@ -387,8 +399,23 @@ doBadNick badNick cs = case NonEmpty.dropWhile (badNick/=) (view (csSettings . ssNicks) cs) of _:next:_ -> ([ircNick next], cs) - _ -> ([], cs) + _ -> doRandomNick cs +-- | Pick a random nickname now that we've run out of choices +doRandomNick :: NetworkState -> ([RawIrcMsg], NetworkState) +doRandomNick cs = ([ircNick candidate], cs') + where + limit = 9 -- RFC 2812 puts the maximum nickname length as low as 9! + range = (0, 99999::Int) -- up to 5 random digits + suffix = show n + primaryNick = NonEmpty.head (view (csSettings . ssNicks) cs) + candidate = Text.take (limit-length suffix) primaryNick <> Text.pack suffix + cs' = set csSeed seed' cs + + (n, seed') = ST.runST (do gen <- Random.restore (view csSeed cs) + (,) <$> Random.uniformR range gen <*> Random.save gen + ) + doTopic :: ZonedTime -> UserInfo -> Identifier -> Text -> NetworkState -> NetworkState doTopic when user chan topic = overChannel chan (setTopic topic . set chanTopicProvenance (Just $! prov)) @@ -709,31 +736,30 @@ | otherwise = [] ss = view csSettings cs - sasl = ["sasl" | isJust (view ssSaslUsername ss) - , isJust (view ssSaslPassword ss) || - isJust (view ssSaslEcdsaFile ss) || - isJust (view ssTlsClientCert ss) ] + sasl = ["sasl" | isJust (view ssSaslMechanism ss) ] doAuthenticate :: Text -> NetworkState -> ([RawIrcMsg], NetworkState) doAuthenticate param cs = case view csAuthenticationState cs of AS_PlainStarted - | "+" <- param - , Just user <- view ssSaslUsername ss - , Just pass <- view ssSaslPassword ss - -> (ircAuthenticates (encodePlainAuthentication user pass), + | "+" <- param + , Just (SaslPlain mbAuthz authc (SecretText pass)) <- view ssSaslMechanism ss + , let authz = fromMaybe "" mbAuthz + -> (ircAuthenticates (encodePlainAuthentication authz authc pass), set csAuthenticationState AS_None cs) AS_ExternalStarted - | "+" <- param - , Just user <- view ssSaslUsername ss - -> (ircAuthenticates (encodeExternalAuthentication user), + | "+" <- param + , Just (SaslExternal mbAuthz) <- view ssSaslMechanism ss + , let authz = fromMaybe "" mbAuthz + -> (ircAuthenticates (encodeExternalAuthentication authz), set csAuthenticationState AS_None cs) AS_EcdsaStarted - | "+" <- param - , Just user <- view ssSaslUsername ss - -> (ircAuthenticates (Ecdsa.encodeUsername user), + | "+" <- param + , Just (SaslEcdsa mbAuthz authc _) <- view ssSaslMechanism ss + , let authz = fromMaybe authc mbAuthz + -> (ircAuthenticates (Ecdsa.encodeAuthentication authz authc), set csAuthenticationState AS_EcdsaWaitChallenge cs) AS_EcdsaWaitChallenge -> ([], cs) -- handled in Client.EventLoop! @@ -753,10 +779,11 @@ prevCaps = view (csTransaction . _CapLsTransaction) cs CapLs CapDone caps - | null reqCaps -> endCapTransaction cs - | otherwise -> ([ircCapReq reqCaps], cs) + | null reqCaps -> ([ircCapEnd], cs') + | otherwise -> ([ircCapReq reqCaps], cs') where reqCaps = selectCaps cs (caps ++ view (csTransaction . _CapLsTransaction) cs) + cs' = set csTransaction NoTransaction cs CapNew caps | null reqCaps -> ([], cs) @@ -767,32 +794,26 @@ CapDel _ -> ([],cs) CapAck caps - | "sasl" `elem` caps && isJust (view ssSaslUsername ss) -> - if isJust (view ssSaslEcdsaFile ss) - then ( [ircAuthenticate Ecdsa.authenticationMode] - , set csAuthenticationState AS_EcdsaStarted cs) - else if isJust (view ssSaslPassword ss) - then ( [ircAuthenticate "PLAIN"] - , set csAuthenticationState AS_PlainStarted cs) - else if isJust (view ssTlsClientCert ss) - then ( [ircAuthenticate "EXTERNAL"] - , set csAuthenticationState AS_ExternalStarted cs) - else endCapTransaction cs - where - ss = view csSettings cs - - _ -> endCapTransaction cs + | let ss = view csSettings cs + , "sasl" `elem` caps + , Just mech <- view ssSaslMechanism ss -> + case mech of + SaslEcdsa{} -> + ([ircAuthenticate Ecdsa.authenticationMode], + set csAuthenticationState AS_EcdsaStarted cs) + SaslPlain{} -> + ([ircAuthenticate "PLAIN"], + set csAuthenticationState AS_PlainStarted cs) + SaslExternal{} -> + ([ircAuthenticate "EXTERNAL"], + set csAuthenticationState AS_ExternalStarted cs) -endCapTransaction :: NetworkState -> ([RawIrcMsg], NetworkState) -endCapTransaction cs = - case view csTransaction cs of - CapTransaction -> ([ircCapEnd], set csTransaction NoTransaction cs) - _ -> ([], cs) + _ -> ([ircCapEnd], cs) initialMessages :: NetworkState -> [RawIrcMsg] initialMessages cs = [ ircCapLs ] - ++ [ ircPass pass | Just pass <- [view ssPassword ss]] + ++ [ ircPass pass | Just (SecretText pass) <- [view ssPassword ss]] ++ [ ircNick (views ssNicks NonEmpty.head ss) , ircUser (view ssUser ss) (view ssReal ss) ] diff --git a/src/Client/View/Digraphs.hs b/src/Client/View/Digraphs.hs --- a/src/Client/View/Digraphs.hs +++ b/src/Client/View/Digraphs.hs @@ -32,11 +32,10 @@ = map (mconcat . intersperse sep) $ chunksOf entriesPerLine $ map (text' defAttr) - $ matcher + $ clientFilter st LText.fromStrict $ map (Text.pack . drawEntry) $ Text.chunksOf 3 digraphs where - matcher = maybe id (\m -> filter (matcherPred m . LText.fromStrict)) (clientMatcher st) entriesPerLine = max 1 -- just in case? $ (w + sepWidth) `quot` (entryWidth + sepWidth) diff --git a/src/Client/View/KeyMap.hs b/src/Client/View/KeyMap.hs --- a/src/Client/View/KeyMap.hs +++ b/src/Client/View/KeyMap.hs @@ -21,14 +21,15 @@ import Graphics.Vty.Attributes import Graphics.Vty.Input --- | Render the lines of a table showing all of the available digraph entries +-- | Show the client keybindings keyMapLines :: ClientState {- ^ client state -} -> [Image'] {- ^ output lines -} -keyMapLines - = renderEntries - . keyMapEntries - . view (clientConfig . configKeyMap) +keyMapLines st + = clientFilter st imageText + $ renderEntries + $ keyMapEntries + $ view (clientConfig . configKeyMap) st renderEntries :: [([Modifier], Key, Action)] -> [Image'] renderEntries entries = diff --git a/src/Client/View/MaskList.hs b/src/Client/View/MaskList.hs --- a/src/Client/View/MaskList.hs +++ b/src/Client/View/MaskList.hs @@ -59,12 +59,10 @@ char (view palLabel pal) '/' <> string defAttr (show (HashMap.size entries)) - matcher = maybe (const True) matcherPred (clientMatcher st) . LText.fromStrict - - matcher' (mask,entry) = matcher mask || matcher (view maskListSetter entry) + filterOn (mask,entry) = LText.fromChunks [mask, " ", view maskListSetter entry] entryList = sortBy (flip (comparing (view (_2 . maskListTime)))) - $ filter matcher' + $ clientFilter st filterOn $ HashMap.toList entries renderWhen = formatTime defaultTimeLocale " %F %T" diff --git a/src/Client/View/Mentions.hs b/src/Client/View/Mentions.hs --- a/src/Client/View/Mentions.hs +++ b/src/Client/View/Mentions.hs @@ -26,7 +26,6 @@ import Control.Lens import qualified Data.Map as Map import Data.Time (UTCTime) -import ContextFilter (filterContext) -- | Generate the list of message lines marked important ordered by -- time. Each run of lines from the same channel will be grouped @@ -42,10 +41,9 @@ padAmt = view (clientConfig . configNickPadding) st palette = clientPalette st - filt = - case clientMatcher st of - Nothing -> filter (\x -> WLImportant == view wlImportance x) - Just (Matcher b a p) -> filterContext b a (views wlText p) + filt + | clientIsFiltered st = filter (\x -> WLImportant == view wlImportance x) + | otherwise = clientFilter st (view wlText) entries = merge [windowEntries filt palette w padAmt detail n focus v @@ -68,7 +66,7 @@ [Image'] {- ^ mention images and channel labels -} addMarkers _ _ [] = [] addMarkers w !st (!ml : xs) - = minorStatusLineImage (mlFocus ml) w False st + = minorStatusLineImage (mlFocus ml) FocusMessages w False st : concatMap mlImage (ml:same) ++ addMarkers w st rest where diff --git a/src/Client/View/Messages.hs b/src/Client/View/Messages.hs --- a/src/Client/View/Messages.hs +++ b/src/Client/View/Messages.hs @@ -31,7 +31,6 @@ import Irc.Identifier import Irc.Message import Irc.UserInfo -import ContextFilter (filterContext) chatMessageImages :: Focus -> Int -> ClientState -> [Image'] @@ -41,9 +40,9 @@ Just win -> let msgs = toListOf each (view winMessages win) hideMeta = view winHideMeta win in - case clientMatcher st of - Just (Matcher a b p) -> windowLineProcessor hideMeta (filterContext b a (views wlText p) msgs) - Nothing -> + if clientIsFiltered st + then windowLineProcessor hideMeta (clientFilter st (view wlText) msgs) + else case view winMarker win of Nothing -> windowLineProcessor hideMeta msgs Just n -> diff --git a/src/Client/View/UserList.hs b/src/Client/View/UserList.hs --- a/src/Client/View/UserList.hs +++ b/src/Client/View/UserList.hs @@ -53,8 +53,6 @@ where countImage = drawSigilCount pal (map snd usersList) - matcher = maybe (const True) matcherPred (clientMatcher st) - myNicks = clientHighlights cs st renderUser (ident, sigils) = @@ -63,10 +61,10 @@ gap = char defAttr ' ' - matcher' (ident,sigils) = matcher (LText.fromChunks [Text.pack sigils, idText ident]) + filterOn (ident,sigils) = LText.fromChunks [Text.pack sigils, idText ident] usersList = sortBy (comparing fst) - $ filter matcher' + $ clientFilter st filterOn $ HashMap.toList usersHashMap pal = clientPalette st @@ -106,8 +104,6 @@ userInfoImages' :: NetworkState -> Identifier -> ClientState -> [Image'] userInfoImages' cs channel st = countImage : map renderEntry usersList where - matcher = maybe (const True) matcherPred (clientMatcher st) - countImage = drawSigilCount pal (map snd usersList) myNicks = clientHighlights cs st @@ -119,8 +115,8 @@ coloredUserInfo pal DetailedRender myNicks info <> " " <> text' (view palMeta pal) (cleanText acct) - matcher' ((info, acct),sigils) = - matcher (LText.fromChunks [Text.pack sigils, renderUserInfo info, " ", acct]) + filterOn ((info, acct),sigils) = + LText.fromChunks [Text.pack sigils, renderUserInfo info, " ", acct] userInfos = view csUsers cs @@ -130,7 +126,7 @@ Nothing -> (UserInfo nick "" "", "") usersList = sortBy (flip (comparing (userNick . fst . fst))) - $ filter matcher' + $ clientFilter st filterOn $ map (over _1 toInfo) $ HashMap.toList usersHashMap