glirc 2.35 → 2.36

raw patch · 39 files changed

+3271/−2737 lines, 39 filesdep +mwc-randomdep ~basedep ~base64-bytestringdep ~hookupnew-component:exe:glircPVP ok

version bump matches the API change (PVP)

Dependencies added: mwc-random

Dependency ranges changed: base, base64-bytestring, hookup, irc-core, template-haskell, time, vty

API changes (from Hackage documentation)

Files

• ChangeLog.md +37/−1
• README.md +1/−1
• exec/Exports.hs +1/−1
• exec/Main.hs +1/−1
• glirc.1 +64/−0
• glirc.cabal +24/−11
• src/Client/Authentication/Ecdsa.hs +7/−5
• src/Client/Commands.hs +497/−2472
• src/Client/Commands/Channel.hs +326/−0
• src/Client/Commands/Chat.hs +522/−0
• src/Client/Commands/Connection.hs +110/−0
• src/Client/Commands/DCC.hs +111/−0
• src/Client/Commands/Operator.hs +127/−0
• src/Client/Commands/Queries.hs +195/−0
• src/Client/Commands/TabCompletion.hs +107/−0
• src/Client/Commands/Toggles.hs +69/−0
• src/Client/Commands/Types.hs +87/−0
• src/Client/Commands/Window.hs +508/−0
• src/Client/Commands/ZNC.hs +101/−0
• src/Client/Configuration.hs +2/−3
• src/Client/Configuration/ServerSettings.hs +107/−49
• src/Client/EventLoop/Network.hs +6/−6
• src/Client/Hook/FreRelay.hs +1/−0
• src/Client/Hook/Znc/Buffextras.hs +1/−1
• src/Client/Image/Layout.hs +13/−12
• src/Client/Image/Message.hs +25/−13
• src/Client/Image/StatusLine.hs +12/−12
• src/Client/Message.hs +1/−1
• src/Client/Network/Connect.hs +17/−12
• src/Client/Options.hs +3/−3
• src/Client/State.hs +98/−54
• src/Client/State/DCC.hs +2/−3
• src/Client/State/Network.hs +67/−46
• src/Client/View/Digraphs.hs +1/−2
• src/Client/View/KeyMap.hs +6/−5
• src/Client/View/MaskList.hs +2/−4
• src/Client/View/Mentions.hs +4/−6
• src/Client/View/Messages.hs +3/−4
• src/Client/View/UserList.hs +5/−9

@@ -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`

@@ -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:

@@ -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

@@ -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 

@@ -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

@@ -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

@@ -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@

@@ -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

@@ -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

@@ -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

@@ -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)

@@ -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)

@@ -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

@@ -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

@@ -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+

@@ -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

@@ -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+

@@ -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

@@ -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

@@ -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

@@ -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)))

@@ -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

@@ -126,6 +126,7 @@     (UserInfo (mkId (nick <> "@" <> srv)) user host)     chan     "" -- account+    "" -- gecos  partMsg ::   Identifier {- ^ channel        -} ->

@@ -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

@@ -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 

@@ -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 " <>

@@ -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

@@ -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'

@@ -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     }  

@@ -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

@@ -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

@@ -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

@@ -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)      ]

@@ -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) 

@@ -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 =

@@ -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"

@@ -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

@@ -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  ->

@@ -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