diff --git a/ChangeLog.md b/ChangeLog.md --- a/ChangeLog.md +++ b/ChangeLog.md @@ -1,5 +1,14 @@ # Revision history for glirc2 +## 2.17 + +* Add `reconnect-attempts` setting +* Add peristence for `/grep` and `/grepi` +* Add filter argument to `/windows` +* Better tab completion for `/channel` and `/focus` +* Isolate and number urls in view with `/url` +* Map `M-Left` and `M-Right` to backward word and forward word + ## 2.16 * Add `/splits` to show multiple chat windows simultaneously diff --git a/README.md b/README.md --- a/README.md +++ b/README.md @@ -3,6 +3,8 @@ [![Build Status](https://secure.travis-ci.org/glguy/irc-core.svg)](http://travis-ci.org/glguy/irc-core) +[Wiki Documentation](https://github.com/glguy/irc-core/wiki) + ![](https://raw.githubusercontent.com/wiki/glguy/irc-core/images/screenshot.png) Building @@ -31,7 +33,7 @@ $ cabal build ``` -Building with stack using ghc-8 resolver (nightly resolvers can work using --solver) +Building with stack using ghc-8 resolver (lts-7 resolvers can work using --solver) ``` $ stack init --resolver=ghc-8 @@ -73,6 +75,7 @@ ``` glirc [FLAGS] INITIAL_NETWORKS... -c PATH --config=PATH Configuration file path + -! --noconnect Disable autoconnecting -h --help Show help -v --version Show version ``` @@ -176,6 +179,7 @@ | `url-opener` | text | Command to execute with URL parameter for `/url` e.g. gnome-open on GNOME or open on macOS | | `ignores` | list of text | Initial list of nicknames to ignore | | `activity-bar` | yes or no | Initial setting for visibility of activity bar (default no) | +| `macros` | list of macros | User-configurable client commands | Server Settings --------------- @@ -202,6 +206,9 @@ | `flood-penalty` | number | cost in seconds per message | | `flood-threshold` | number | threshold in seconds for burst | | `message-hooks` | list of text | names of hooks to enable | +| `reconnect-attempts` | int | number of reconnections to attempt on error | +| `autoconnect` | yes or no | automatically connect at client startup | +| `nick-completion` | default or slack | set this to slack to use `@` sigils when completing nicks | Palette ------- @@ -263,7 +270,7 @@ * `/disconnect` - Forcefully terminate connection to the current server * `/reconnect` - Reconnect to the current server * `/reload [path]` - Load a new configuration file (optional path) -* `/windows` - List all open windows +* `/windows [filter]` - List all open windows (filters: networks, channels, users) * `/palette` - Show the client palette * `/mentions` - Show all the highlighted lines across all windows * `/extension ` - Send the given params to the named extension @@ -367,6 +374,8 @@ * `C-t` swap characters at cursor * `M-f` forward word * `M-b` backward word +* `M-Right` forward word +* `M-Left` backward word * `M-Backspace` delete word backwards * `M-d` delete word forwards * `M-Enter` insert newline diff --git a/exec/Main.hs b/exec/Main.hs --- a/exec/Main.hs +++ b/exec/Main.hs @@ -13,6 +13,7 @@ import Control.Concurrent import Control.Lens import Control.Monad +import Data.List (nub) import Data.Text (Text) import System.Exit import System.IO @@ -31,9 +32,16 @@ runInUnboundThread $ withClientState cfg $ clientStartExtensions >=> - addInitialNetworks (view optInitialNetworks opts) >=> + initialNetworkLogic opts >=> eventLoop +initialNetworkLogic :: Options -> ClientState -> IO ClientState +initialNetworkLogic opts st + | view optNoConnect opts = return st + | otherwise = addInitialNetworks networks st + where + networks = nub (clientAutoconnects st ++ view optInitialNetworks opts) + -- | Load configuration and handle errors along the way. loadConfiguration' :: Maybe FilePath -> IO Configuration loadConfiguration' path = @@ -52,15 +60,13 @@ hPutStrLn stderr msg exitFailure --- | Create connections for all the networks on the command line. +-- | Create connections for the given networks. -- Set the client focus to the first network listed. addInitialNetworks :: [Text] {- networks -} -> ClientState -> IO ClientState -addInitialNetworks networks st = - case networks of - [] -> return st - network:_ -> - do st' <- foldM (flip (addConnection 0 Nothing)) st networks - return (set clientFocus (NetworkFocus network) st') +addInitialNetworks [] st = return st +addInitialNetworks (n:ns) st = + do st' <- foldM (flip (addConnection 0 Nothing)) st (n:ns) + return $! set clientFocus (NetworkFocus n) st' diff --git a/glirc.cabal b/glirc.cabal --- a/glirc.cabal +++ b/glirc.cabal @@ -1,7 +1,12 @@ name: glirc -version: 2.16 +version: 2.17 synopsis: Console IRC client description: Console IRC client + . + glirc is a console IRC client with an emphasis on providing + dynamic views into the model of your IRC connections. + . + license: ISC license-file: LICENSE author: Eric Mertens @@ -91,6 +96,7 @@ Client.View.Mentions Client.View.Messages Client.View.Palette + Client.View.UrlSelection Client.View.UserList Client.View.Windows Config.FromConfig diff --git a/src/Client/CApi/Types.hsc b/src/Client/CApi/Types.hsc --- a/src/Client/CApi/Types.hsc +++ b/src/Client/CApi/Types.hsc @@ -48,28 +48,42 @@ import Foreign.Ptr import Foreign.Storable +-- | Tag for describing the kind of message to display in the client +-- as used in `glirc_print`. +-- +-- @enum message_code;@ newtype MessageCode = MessageCode CInt deriving Eq #enum MessageCode, MessageCode, NORMAL_MESSAGE, ERROR_MESSAGE +-- | Result used to determine what to do after processing a message with +-- the 'ProcessMessage' callback. +-- +-- @enum process_result;@ newtype MessageResult = MessageResult CInt deriving Eq #enum MessageResult, MessageResult, PASS_MESSAGE, DROP_MESSAGE +-- + +-- | @typedef void *start(void *glirc, const char *path);@ type StartExtension = Ptr () {- ^ api token -} -> CString {- ^ path to extension -} -> IO (Ptr ()) {- ^ initialized extension state -} +-- | @typedef void stop(void *glirc, void *S);@ type StopExtension = Ptr () {- ^ api token -} -> Ptr () {- ^ extension state -} -> IO () +-- | Type of @typedef enum process_result process_message(void *glirc, void *S, const struct glirc_message *);@ type ProcessMessage = Ptr () {- ^ api token -} -> Ptr () {- ^ extention state -} -> Ptr FgnMsg {- ^ message to send -} -> IO MessageResult +-- | @typedef void process_command(void *glirc, void *S, const struct glirc_command *);@ type ProcessCommand = Ptr () {- ^ api token -} -> Ptr () {- ^ extension state -} -> @@ -86,14 +100,14 @@ ------------------------------------------------------------------------ --- | @struct glirc_extension@ +-- | @struct glirc_extension;@ data FgnExtension = FgnExtension - { fgnStart :: FunPtr StartExtension -- ^ Optional callback - , fgnStop :: FunPtr StopExtension -- ^ Optional callback - , fgnMessage :: FunPtr ProcessMessage -- ^ Optional callback - , fgnCommand :: FunPtr ProcessCommand -- ^ Optional callback + { fgnStart :: FunPtr StartExtension -- ^ Optional startup callback + , fgnStop :: FunPtr StopExtension -- ^ Optional shutdown callback + , fgnMessage :: FunPtr ProcessMessage -- ^ Optional message received callback + , fgnCommand :: FunPtr ProcessCommand -- ^ Optional client command callback , fgnName :: CString -- ^ Null-terminated name - , fgnMajorVersion, fgnMinorVersion :: CInt + , fgnMajorVersion, fgnMinorVersion :: CInt -- ^ extension version } instance Storable FgnExtension where diff --git a/src/Client/Commands.hs b/src/Client/Commands.hs --- a/src/Client/Commands.hs +++ b/src/Client/Commands.hs @@ -31,7 +31,6 @@ import Client.Commands.Recognizer import Client.Commands.WordCompletion import Client.Configuration -import Client.Configuration.ServerSettings import Client.Message import Client.State import Client.State.Channel @@ -64,6 +63,7 @@ import System.Process import Text.Read import Text.Regex.TDFA +import Text.Regex.TDFA.String (compile) -- | Possible results of running a command data CommandResult @@ -98,9 +98,21 @@ -- | requires an active channel window | ChannelCommand (ChannelCommand a) (Bool -> ChannelCommand String) --- | A command is an argument specification, implementation, and documentation -data Command = forall a. Command (ArgumentSpec a) Text (CommandImpl a) +-- | 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 :: ArgumentSpec 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 + } + -- | Consider the text entry successful and resume the client commandSuccess :: Monad m => ClientState -> m CommandResult commandSuccess = return . CommandSuccess @@ -224,7 +236,7 @@ in case recognize cmdTxt commands of - Exact (Command argSpec _docs impl) -> + Exact Command{cmdImplementation=impl, cmdArgumentSpec=argSpec} -> case impl of ClientCommand exec tab -> finish argSpec exec tab @@ -254,8 +266,9 @@ -- | Expands each alias to have its own copy of the command callbacks -expandAliases :: [(NonEmpty a,b)] -> [(a,b)] -expandAliases xs = [ (a,b) | (as,b) <- xs, a <- toList as ] +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 @@ -263,25 +276,28 @@ commands :: Recognizer Command commands = fromCommands (expandAliases commandsList) -commandsList :: [(NonEmpty Text,Command)] +commandsList :: [Command] commandsList = -- -- Client commands -- - [ ( pure "connect" - , Command (ReqTokenArg "network" NoArg) + [ Command + (pure "connect") + (ReqTokenArg "network" NoArg) "Connect to \^Bnetwork\^B by name.\n\ \\n\ \If no name is configured the hostname is the 'name'.\n" $ ClientCommand cmdConnect tabConnect - ) - , ( pure "exit" - , Command NoArg + + , Command + (pure "exit") + NoArg "Exit the client immediately.\n" $ ClientCommand cmdExit noClientTab - ) - , ( pure "focus" - , Command (ReqTokenArg "network" (OptTokenArg "channel" NoArg)) + + , Command + (pure "focus") + (ReqTokenArg "network" (OptTokenArg "channel" NoArg)) "Change the focused window.\n\ \\n\ \When only \^Bnetwork\^B is specified this switches to the network status window.\n\ @@ -290,9 +306,10 @@ \Nicknames can be specified in the \^Bchannel\^B parameter to switch to private chat.\n\ \See also: /channel (aliased /c) to switch to a channel on the current network.\n" $ ClientCommand cmdFocus tabFocus - ) - , ( pure "clear" - , Command (OptTokenArg "network" (OptTokenArg "channel" NoArg)) + + , Command + (pure "clear") + (OptTokenArg "network" (OptTokenArg "channel" NoArg)) "Clear a window.\n\ \\n\ \If no arguments are provided the current window is cleared.\n\ @@ -300,50 +317,61 @@ \If \^Bnetwork\^B and \^Bchannel\^B are provided that chat window is cleared.\n\ \\n\ \If a window is cleared and no longer active that window will be removed from the client.\n" - $ ClientCommand cmdClear noClientTab - ) - , ( pure "reconnect" - , Command NoArg + $ ClientCommand cmdClear tabFocus + + , Command + (pure "reconnect") + NoArg "Reconnect to the current network.\n" $ ClientCommand cmdReconnect noClientTab - ) - , ( pure "ignore" - , Command (RemainingArg "nicks") + + , Command + (pure "ignore") + (RemainingArg "nicks") "Toggle the soft-ignore on each of the space-delimited given nicknames.\n" $ ClientCommand cmdIgnore simpleClientTab - ) - , ( pure "reload" - , Command (OptTokenArg "filename" NoArg) + + , Command + (pure "reload") + (OptTokenArg "filename" NoArg) "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 - ) - , ( pure "extension" - , Command (ReqTokenArg "extension" (RemainingArg "arguments")) + + , Command + (pure "extension") + (ReqTokenArg "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 - ) - , ( pure "windows" - , Command NoArg - "Show a list of all client message windows.\n" - $ ClientCommand cmdWindows noClientTab - ) - , ( pure "mentions" - , Command NoArg + + , Command + (pure "windows") + (OptTokenArg "kind" NoArg) + "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 "mentions") + NoArg "Show a list of all message that were highlighted as important.\n" $ ClientCommand cmdMentions noClientTab - ) - , ( pure "palette" - , Command NoArg + + , Command + (pure "palette") + NoArg "Show the current palette settings and a color chart to help pick new colors.\n" $ ClientCommand cmdPalette noClientTab - ) - , ( pure "exec" - , Command (RemainingArg "arguments") + + , 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 [command arguments...]\n\ @@ -360,9 +388,10 @@ \ escaped characters and spaces inside.\n\ \\n" $ ClientCommand cmdExec simpleClientTab - ) - , ( pure "url" - , Command (OptTokenArg "number" NoArg) + + , Command + (pure "url") + (OptTokenArg "number" NoArg) "Open a URL seen in chat.\n\ \\n\ \The URL is opened using the executable configured under \^Burl-opener\^B.\n\ @@ -371,48 +400,75 @@ \\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 - ) - , ( pure "help" - , Command (OptTokenArg "command" NoArg) + , Command + (pure "help") + (OptTokenArg "command" NoArg) "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 - ) - , ( pure "splits" - , Command (RemainingArg "focuses") + , Command + (pure "splits") + (RemainingArg "focuses") "Set the extra message view splits.\n\ \\n\ - \\^Bfocues\^B: space delimited list of focus names.\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" + \User: \^BNETWORK\^B:\^BNICK\^B\n\ + \\n\ + \Not providing an argument unsplits the current windows.\n" $ ClientCommand cmdSplits tabSplits - ) + , Command + (pure "grep") + (RemainingArg "regular-expression") + "Set the persistent regular expression.\n\ + \\n\ + \Clear the regular expression by calling this without an argument.\n\ + \\n\ + \\^B/grep\^O is case-sensitive.\n\ + \\^B/grepi\^O is case-insensitive.\n" + $ ClientCommand (cmdGrep True) simpleClientTab + + , Command + (pure "grepi") + (RemainingArg "regular-expression") + "Set the persistent regular expression.\n\ + \\n\ + \Clear the regular expression by calling this without an argument.\n\ + \\n\ + \\^B/grep\^O is case-sensitive.\n\ + \\^B/grepi\^O is case-insensitive.\n" + $ ClientCommand (cmdGrep False) simpleClientTab + + -- -- Network commands -- - , ( pure "quote" - , Command (RemainingArg "raw IRC command") + , Command + (pure "quote") + (RemainingArg "raw IRC command") "Send a raw IRC command.\n" $ NetworkCommand cmdQuote simpleNetworkTab - ) - , ( "join" :| ["j"] - , Command (ReqTokenArg "channels" (OptTokenArg "keys" NoArg)) + + , Command + ("join" :| ["j"]) + (ReqTokenArg "channels" (OptTokenArg "keys" NoArg)) "Join a chat channel.\n\ \\n\ \\^Bchannels\^B: comma-separated list of channels\n\ \\^Bkeys\^B: comma-separated list of keys\n" $ NetworkCommand cmdJoin simpleNetworkTab - ) - , ( "channel" :| ["c"] - , Command (ReqTokenArg "channel" NoArg) + + , Command + ("channel" :| ["c"]) + (ReqTokenArg "channel" NoArg) "Change the focused window.\n\ \\n\ \Changes the focus to the \^Bchannel\^B chat window on the current network.\n\ @@ -420,10 +476,11 @@ \Nicknames can be specified in the \^Bchannel\^B parameter to switch to private chat.\n\ \See also: /focus to switch to a channel on a different network.\n\ \See also: /focus to switch to a channel on a different network.\n" - $ NetworkCommand cmdChannel simpleNetworkTab - ) - , ( pure "mode" - , Command (RemainingArg "modes and parameters") + $ NetworkCommand cmdChannel tabChannel + + , Command + (pure "mode") + (RemainingArg "modes and parameters") "Sets IRC modes.\n\ \\n\ \Examples:\n\ @@ -437,23 +494,26 @@ \\n\ \This command has parameter sensitive tab-completion.\n" $ NetworkCommand cmdMode tabMode - ) - , ( pure "msg" - , Command (ReqTokenArg "target" (RemainingArg "message")) + + , Command + (pure "msg") + (ReqTokenArg "target" (RemainingArg "message")) "Send a chat message to a user or a channel.\n\ \\n\ \\^Btarget\^B can be a channel or nickname.\n" $ NetworkCommand cmdMsg simpleNetworkTab - ) - , ( pure "notice" - , Command (ReqTokenArg "target" (RemainingArg "message")) + + , Command + (pure "notice") + (ReqTokenArg "target" (RemainingArg "message")) "Send a notice message to a user or a channel. Notices are typically used by bots.\n\ \\n\ \\^Btarget\^B can be a channel or nickname.\n" $ NetworkCommand cmdNotice simpleNetworkTab - ) - , ( pure "ctcp" - , Command (ReqTokenArg "target" (ReqTokenArg "command" (RemainingArg "arguments"))) + + , Command + (pure "ctcp") + (ReqTokenArg "target" (ReqTokenArg "command" (RemainingArg "arguments"))) "Send a CTCP command to a user or a channel.\n\ \\n\ \Examples:\n\ @@ -464,84 +524,98 @@ \\^Bcommand\^B can be any CTCP command.\n\ \\^Barguments\^B are specific to a particular command.\n" $ NetworkCommand cmdCtcp simpleNetworkTab - ) - , ( pure "nick" - , Command (ReqTokenArg "nick" NoArg) + + , Command + (pure "nick") + (ReqTokenArg "nick" NoArg) "Change your nickname.\n" $ NetworkCommand cmdNick simpleNetworkTab - ) - , ( pure "quit" - , Command (RemainingArg "reason") + + , 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 - ) - , ( pure "disconnect" - , Command NoArg + + , Command + (pure "disconnect") + NoArg "Immediately terminate the current network connection.\n\ \\n\ \See also: /quit /exit\n" $ NetworkCommand cmdDisconnect noNetworkTab - ) - , ( pure "who" - , Command (RemainingArg "arguments") + + , Command + (pure "who") + (RemainingArg "arguments") "Send WHO query to server with given arguments.\n" $ NetworkCommand cmdWho simpleNetworkTab - ) - , ( pure "whois" - , Command (RemainingArg "arguments") + + , Command + (pure "whois") + (RemainingArg "arguments") "Send WHOIS query to server with given arguments.\n" $ NetworkCommand cmdWhois simpleNetworkTab - ) - , ( pure "whowas" - , Command (RemainingArg "arguments") + + , Command + (pure "whowas") + (RemainingArg "arguments") "Send WHOWAS query to server with given arguments.\n" $ NetworkCommand cmdWhowas simpleNetworkTab - ) - , ( pure "ison" - , Command (RemainingArg "arguments") + + , Command + (pure "ison") + (RemainingArg "arguments") "Send ISON query to server with given arguments.\n" $ NetworkCommand cmdIson simpleNetworkTab - ) - , ( pure "userhost" - , Command (RemainingArg "arguments") + + , Command + (pure "userhost") + (RemainingArg "arguments") "Send USERHOST query to server with given arguments.\n" $ NetworkCommand cmdUserhost simpleNetworkTab - ) - , ( pure "away" - , Command (RemainingArg "message") + + , Command + (pure "away") + (RemainingArg "message") "Set away status.\n\ \\n\ \When \^Bmessage\^B is omitted away status is cleared.\n" - $ NetworkCommand cmdAway simpleNetworkTab - ) - , ( pure "links" - , Command (RemainingArg "arguments") + $ NetworkCommand cmdAway simpleNetworkTab + + , Command + (pure "links") + (RemainingArg "arguments") "Send LINKS query to server with given arguments.\n" - $ NetworkCommand cmdLinks simpleNetworkTab - ) - , ( pure "time" - , Command (RemainingArg "arguments") + $ NetworkCommand cmdLinks simpleNetworkTab + + , Command + (pure "time") + (RemainingArg "arguments") "Send TIME query to server with given arguments.\n" - $ NetworkCommand cmdTime simpleNetworkTab - ) - , ( pure "stats" - , Command (RemainingArg "arguments") + $ NetworkCommand cmdTime simpleNetworkTab + + , Command + (pure "stats") + (RemainingArg "arguments") "Send STATS query to server with given arguments.\n" - $ NetworkCommand cmdStats simpleNetworkTab - ) - , ( pure "znc" - , Command (RemainingArg "arguments") + $ NetworkCommand cmdStats simpleNetworkTab + + , 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 - ) - , ( pure "znc-playback" - , Command (OptTokenArg "time" (OptTokenArg "date" NoArg)) + $ NetworkCommand cmdZnc simpleNetworkTab + + , Command + (pure "znc-playback") + (OptTokenArg "time" (OptTokenArg "date" NoArg)) "Request playback from the ZNC 'playback' module.\n\ \\n\ \\^Btime\^B determines the time to playback since.\n\ @@ -555,64 +629,71 @@ \\n\ \Note that the playback module is not installed in ZNC by default!\n" $ NetworkCommand cmdZncPlayback noNetworkTab - ) - , ( pure "invite" - , Command (ReqTokenArg "nick" NoArg) + , Command + (pure "invite") + (ReqTokenArg "nick" NoArg) "Invite a user to the current channel.\n" $ ChannelCommand cmdInvite simpleChannelTab - ) - , ( pure "topic" - , Command (RemainingArg "message") + + , 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 - ) - , ( pure "kick" - , Command (ReqTokenArg "nick" (RemainingArg "reason")) + + , Command + (pure "kick") + (ReqTokenArg "nick" (RemainingArg "reason")) "Kick a user from the current channel.\n\ \\n\ \See also: /kickban /remove\n" $ ChannelCommand cmdKick simpleChannelTab - ) - , ( pure "kickban" - , Command (ReqTokenArg "nick" (RemainingArg "reason")) + + , Command + (pure "kickban") + (ReqTokenArg "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 - ) - , ( pure "remove" - , Command (ReqTokenArg "nick" (RemainingArg "reason")) + + , Command + (pure "remove") + (ReqTokenArg "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 - ) - , ( pure "part" - , Command (RemainingArg "reason") + + , Command + (pure "part") + (RemainingArg "reason") "Part from the current channel.\n" $ ChannelCommand cmdPart simpleChannelTab - ) - , ( pure "users" - , Command NoArg + , Command + (pure "users") + NoArg "Show the user list for the current channel.\n\ \\n\ \Detailed view (F2) shows full hostmask.\n\ \Hostmasks can be populated with /who #channel.\n" $ ChannelCommand cmdUsers noChannelTab - ) - , ( pure "channelinfo" - , Command NoArg + + , Command + (pure "channelinfo") + NoArg "Show information about the current channel.\n" $ ChannelCommand cmdChannelInfo noChannelTab - ) - , ( pure "masks" - , Command (ReqTokenArg "mode" NoArg) + + , Command + (pure "masks") + (ReqTokenArg "mode" NoArg) "Show mask lists for current channel.\n\ \\n\ \Common \^Bmode\^B values:\n\ @@ -623,20 +704,20 @@ \\n\ \To populate the mask lists for the first time use: /mode \^Bmode\^B\n" $ ChannelCommand cmdMasks noChannelTab - ) - , ( pure "me" - , Command (RemainingArg "message") + , Command + (pure "me") + (RemainingArg "message") "Send an 'action' to the current chat window.\n" $ ChatCommand cmdMe simpleChannelTab - ) - , ( pure "say" - , Command (RemainingArg "message") + + , Command + (pure "say") + (RemainingArg "message") "Send a message to the current chat window.\n\ \\n\ \This can be useful for sending a chat message with a leading '/'.\n" $ ChatCommand cmdSay simpleChannelTab - ) ] -- | Provides no tab completion for client commands @@ -683,16 +764,17 @@ Just (network, Just (channel, _)) -> clearFocus (ChannelFocus (Text.pack network) (mkId (Text.pack channel))) where - clearFocus focus = commandSuccess (windowEffect st) + clearFocus focus = commandSuccess (focusEffect (windowEffect st)) where windowEffect - | isActive = clearWindow - | otherwise = deleteWindow + | isActive = setWindow (Just emptyWindow) + | otherwise = setWindow Nothing - deleteWindow = advanceFocus . setWindow Nothing - clearWindow = setWindow (Just emptyWindow) + focusEffect + | not isActive && view clientFocus st == focus = advanceFocus + | otherwise = id - setWindow = set (clientWindows . at (view clientFocus st)) + setWindow = set (clientWindows . at focus) isActive = case focus of @@ -823,9 +905,27 @@ 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 () -cmdWindows st _ = commandSuccess (changeSubfocus FocusWindows st) +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 Windows. cmdMentions :: ClientCommand () @@ -849,7 +949,8 @@ newline = Edit.endLine cmd commandSuccess (set (clientTextBox . Edit.line) newline st) - | otherwise = simpleTabCompletion id [] completions isReversed st + | otherwise = + simpleTabCompletion plainWordCompleteMode [] completions isReversed st where currentExtras = view clientExtraFocus st @@ -874,28 +975,30 @@ (net,_:chan) -> ChannelFocus (Text.pack net) (mkId (Text.pack chan)) tabHelp :: Bool -> ClientCommand String -tabHelp isReversed st _ = simpleTabCompletion id [] commandNames isReversed st +tabHelp isReversed st _ = + simpleTabCompletion plainWordCompleteMode [] commandNames isReversed st where - commandNames = [ cmd | (cmd :| _, _) <- commandsList ] + commandNames = fst <$> expandAliases commandsList simpleTabCompletion :: Prefix a => - (String -> String) {- ^ leading transform -} -> - [a] {- ^ hints -} -> - [a] {- ^ all completions -} -> - Bool {- ^ reversed order -} -> - ClientState -> IO CommandResult -simpleTabCompletion lead hints completions isReversed st = + 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 lead isReversed hints completions + tryCompletion = wordComplete mode isReversed hints completions -- | @/connect@ tab completes known server names tabConnect :: Bool -> ClientCommand String tabConnect isReversed st _ = - simpleTabCompletion id [] networks isReversed st + simpleTabCompletion plainWordCompleteMode [] networks isReversed st where networks = views clientNetworkMap HashMap.keys st ++ views (clientConfig . configServers) HashMap.keys st @@ -905,14 +1008,16 @@ -- the current networks are used. tabFocus :: Bool -> ClientCommand String tabFocus isReversed st _ = - simpleTabCompletion id [] completions isReversed st + simpleTabCompletion plainWordCompleteMode [] completions isReversed st where networks = map mkId $ HashMap.keys $ view clientNetworkMap st params = words $ uncurry take $ clientLine st - completions - | length params == 2 = networks - | otherwise = currentCompletionList st + completions = + case params of + [_cmd,_net] -> networks + [_cmd,net,_chan] -> channelWindowsOnNetwork (Text.pack net) st + _ -> [] cmdWhois :: NetworkCommand String cmdWhois cs st rest = @@ -931,7 +1036,7 @@ cmdIson :: NetworkCommand String cmdIson cs st rest = - do sendMsg cs (ircIson (Text.pack <$> words rest)) + do sendMsg cs (ircIson [Text.pack (unwords (words rest))]) commandSuccess st cmdUserhost :: NetworkCommand String @@ -1038,20 +1143,13 @@ commandSuccessUpdateCS :: NetworkState -> ClientState -> IO CommandResult commandSuccessUpdateCS cs st = - let networkId = view csNetworkId cs in - commandSuccess - $ setStrict (clientConnections . ix networkId) cs st + do let networkId = view csNetworkId cs + commandSuccess + $ setStrict (clientConnections . ix networkId) cs st cmdTopic :: ChannelCommand String cmdTopic channelId cs st rest = - do let cmd = - case rest of - "" -> ircTopic channelId "" - topic | useChanServ channelId cs -> - ircPrivmsg "ChanServ" - ("TOPIC " <> idText channelId <> Text.pack (' ' : topic)) - | otherwise -> ircTopic channelId (Text.pack topic) - sendMsg cs cmd + do sendTopic channelId (Text.pack rest) cs commandSuccess st tabTopic :: @@ -1130,7 +1228,26 @@ commandSuccess $ changeFocus (ChannelFocus (view csNetwork cs) (mkId (Text.pack channel))) st +-- | Tab completion for @/channel@ +tabChannel :: + Bool {- ^ reversed order -} -> + NetworkCommand String +tabChannel isReversed cs st _ = + simpleTabCompletion plainWordCompleteMode [] completions isReversed st + where + completions = channelWindowsOnNetwork (view csNetwork cs) st +-- | 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 @@ -1246,7 +1363,7 @@ [ (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 id hint completions isReversed st + -> simpleTabCompletion plainWordCompleteMode hint completions isReversed st _ -> commandFailure st @@ -1315,7 +1432,7 @@ commandNameCompletion :: Bool -> ClientState -> Maybe ClientState commandNameCompletion isReversed st = do guard (cursorPos == n) - clientTextBox (wordComplete id isReversed [] possibilities) st + clientTextBox (wordComplete plainWordCompleteMode isReversed [] possibilities) st where n = length leadingPart (cursorPos, line) = clientLine st @@ -1328,30 +1445,11 @@ -- userlist for the currently focused channel (if any) nickTabCompletion :: Bool {- ^ reversed -} -> ClientState -> IO CommandResult nickTabCompletion isReversed st = - simpleTabCompletion (++": ") hint completions isReversed st + simpleTabCompletion mode hint completions isReversed st where hint = activeNicks st completions = currentCompletionList st - --- | Used to send commands that require ops to perform. --- If this channel is one that the user has chanserv access and ops are needed --- then ops are requested and the commands are queued, otherwise send them --- directly. -sendModeration :: - Identifier {- ^ channel -} -> - [RawIrcMsg] {- ^ commands -} -> - NetworkState {- ^ network state -} -> - IO NetworkState -sendModeration channel cmds cs - | useChanServ channel cs = - do sendMsg cs (ircPrivmsg "ChanServ" ("OP " <> idText channel)) - return $ csChannels . ix channel . chanQueuedModeration <>~ cmds $ cs - | otherwise = cs <$ traverse_ (sendMsg cs) cmds - -useChanServ :: Identifier -> NetworkState -> Bool -useChanServ channel cs = - channel `elem` view (csSettings . ssChanservChannels) cs && - not (iHaveOp channel cs) + mode = currentNickCompletionMode st cmdExtension :: ClientCommand (String, String) cmdExtension st (name,params) = @@ -1440,6 +1538,7 @@ , _msgNetwork = "" } ste + cmdUrl :: ClientCommand (Maybe (String, ())) cmdUrl st mbArg = case view (clientConfig . configUrlOpener) st of @@ -1471,3 +1570,14 @@ case res of Left e -> commandFailureMsg (Text.pack (displayException (e :: IOError))) st Right{} -> commandSuccess st + +-- | Implementation of @/grep@ and @/grepi@ +cmdGrep :: + Bool {- ^ case sensitive -} -> + ClientCommand String +cmdGrep sensitive st str + | null str = commandSuccess (set clientRegex Nothing st) + | otherwise = + case compile defaultCompOpt{caseSensitive=sensitive} defaultExecOpt str of + Left e -> commandFailureMsg (Text.pack e) st + Right r -> commandSuccess (set clientRegex (Just r) st) diff --git a/src/Client/Commands/WordCompletion.hs b/src/Client/Commands/WordCompletion.hs --- a/src/Client/Commands/WordCompletion.hs +++ b/src/Client/Commands/WordCompletion.hs @@ -11,13 +11,18 @@ module Client.Commands.WordCompletion ( Prefix(..) , wordComplete + + -- * Word completion modes + , WordCompletionMode(..) + , plainWordCompleteMode + , defaultNickWordCompleteMode + , slackNickWordCompleteMode ) where import qualified Client.State.EditBox as Edit import Control.Applicative import Control.Lens import Control.Monad -import Data.Char import Data.List import qualified Data.Set as Set import Data.String (IsString(..)) @@ -25,6 +30,20 @@ import Data.Text (Text) import Irc.Identifier +-- | Word completion prefix and suffix +data WordCompletionMode = WordCompletionMode + { wcmStartPrefix, wcmStartSuffix, wcmMiddlePrefix, wcmMiddleSuffix :: String } + deriving Show + +plainWordCompleteMode :: WordCompletionMode +plainWordCompleteMode = WordCompletionMode "" "" "" "" + +defaultNickWordCompleteMode :: WordCompletionMode +defaultNickWordCompleteMode = WordCompletionMode "" ": " "" "" + +slackNickWordCompleteMode :: WordCompletionMode +slackNickWordCompleteMode = WordCompletionMode "@" " " "@" "" + -- | Perform word completion on a text box. -- -- The leading update operation is applied to the result of tab-completion @@ -37,13 +56,13 @@ -- completions. wordComplete :: Prefix a => - (String -> String) {- ^ leading update operation -} -> + WordCompletionMode {- ^ leading update operation -} -> Bool {- ^ reversed -} -> [a] {- ^ priority completions -} -> [a] {- ^ possible completions -} -> Edit.EditBox -> Maybe Edit.EditBox -wordComplete leadingCase isReversed hint vals box = - do let current = currentWord box +wordComplete mode isReversed hint vals box = + do let current = currentWord mode box guard (not (null current)) let cur = fromString current case view Edit.lastOperation box of @@ -51,7 +70,7 @@ | isPrefix pat cur -> do next <- tabSearch isReversed pat cur vals - Just $ replaceWith leadingCase (toString next) box + Just $ replaceWith mode (toString next) box where pat = fromString patternStr @@ -59,23 +78,27 @@ do next <- find (isPrefix cur) hint <|> tabSearch isReversed cur cur vals Just $ set Edit.lastOperation (Edit.TabOperation current) - $ replaceWith leadingCase (toString next) box + $ replaceWith mode (toString next) box -replaceWith :: (String -> String) -> String -> Edit.EditBox -> Edit.EditBox -replaceWith leadingCase str box = +replaceWith :: WordCompletionMode -> String -> Edit.EditBox -> Edit.EditBox +replaceWith (WordCompletionMode spfx ssfx mpfx msfx) str box = let box1 = Edit.killWordBackward False box - str1 | view Edit.pos box1 == 0 = leadingCase str - | otherwise = str + str1 | view Edit.pos box1 == 0 = spfx ++ str ++ ssfx + | otherwise = mpfx ++ str ++ msfx in over Edit.content (Edit.insertString str1) box1 -currentWord :: Edit.EditBox -> String -currentWord box - = reverse - $ takeWhile (not . isSpace) - $ dropWhile (\x -> x==' ' || x==':') +currentWord :: WordCompletionMode -> Edit.EditBox -> String +currentWord (WordCompletionMode spfx ssfx mpfx msfx) box + = dropWhile (`elem`pfx) $ reverse + $ takeWhile (/= ' ') + $ dropWhile (`elem`sfx) + $ reverse $ take n txt - where Edit.Line n txt = view Edit.line box + where + pfx = spfx++mpfx + sfx = ssfx++msfx + Edit.Line n txt = view Edit.line box -- | Class for types that are isomorphic to 'String' -- and which can support a total order and a prefix diff --git a/src/Client/Configuration.hs b/src/Client/Configuration.hs --- a/src/Client/Configuration.hs +++ b/src/Client/Configuration.hs @@ -45,6 +45,7 @@ import Client.Configuration.ServerSettings import Client.Commands.Interpolation import Client.Commands.Recognizer +import Client.Commands.WordCompletion import Control.Exception import Control.Monad import Config @@ -273,7 +274,10 @@ "flood-threshold" -> setField ssFloodThreshold "message-hooks" -> setField ssMessageHooks "name" -> setFieldMb ssName - _ -> failure "Unknown section" + "reconnect-attempts" -> setField ssReconnectAttempts + "autoconnect" -> setField ssAutoconnect + "nick-completion" -> setFieldWith ssNickCompletion parseNickCompletion + _ -> failure "Unknown setting" where setField l = setFieldWith l parseConfig setFieldMb l = setFieldWithMb l parseConfig @@ -342,3 +346,10 @@ case parseExpansion txt of Nothing -> failure "bad macro line" Just ex -> return ex + +parseNickCompletion :: Value -> ConfigParser WordCompletionMode +parseNickCompletion v = + case v of + Atom "default" -> return defaultNickWordCompleteMode + Atom "slack" -> return slackNickWordCompleteMode + _ -> failure "expected default or slack" diff --git a/src/Client/Configuration/ServerSettings.hs b/src/Client/Configuration/ServerSettings.hs --- a/src/Client/Configuration/ServerSettings.hs +++ b/src/Client/Configuration/ServerSettings.hs @@ -39,6 +39,9 @@ , ssFloodThreshold , ssMessageHooks , ssName + , ssReconnectAttempts + , ssAutoconnect + , ssNickCompletion -- * Load function , loadDefaultServerSettings @@ -49,6 +52,7 @@ ) where import Client.Commands.Interpolation +import Client.Commands.WordCompletion import Control.Lens import Data.List.NonEmpty (NonEmpty) import qualified Data.List.NonEmpty as NonEmpty @@ -82,6 +86,9 @@ , _ssFloodThreshold :: !Rational -- ^ Flood limited threshold (seconds) , _ssMessageHooks :: ![Text] -- ^ Initial message hooks , _ssName :: !(Maybe Text) -- ^ The name referencing the server in commands + , _ssReconnectAttempts:: !Int -- ^ The number of reconnect attempts to make on error + , _ssAutoconnect :: Bool -- ^ Connect to this network on server startup + , _ssNickCompletion :: WordCompletionMode -- ^ Nick completion mode for this server } deriving Show @@ -123,4 +130,7 @@ , _ssFloodThreshold = 10 , _ssMessageHooks = [] , _ssName = Nothing + , _ssReconnectAttempts= 6 -- six feels great + , _ssAutoconnect = False + , _ssNickCompletion = defaultNickWordCompleteMode } diff --git a/src/Client/EventLoop.hs b/src/Client/EventLoop.hs --- a/src/Client/EventLoop.hs +++ b/src/Client/EventLoop.hs @@ -1,4 +1,4 @@ -{-# Language OverloadedStrings, NondecreasingIndentation #-} +{-# Language BangPatterns, OverloadedStrings, NondecreasingIndentation #-} {-| Module : Client.EventLoop @@ -35,7 +35,6 @@ import Control.Monad import Data.ByteString (ByteString) import Data.Foldable -import qualified Data.IntMap as IntMap import Data.List import Data.Maybe import Data.Monoid @@ -53,8 +52,6 @@ import LensUtils import Network.Connection -reconnectAttempts :: Int -reconnectAttempts = 6 -- | Sum of the three possible event types the event loop handles data ClientEvent @@ -76,20 +73,10 @@ where vtyEventChannel = _eventChannel (inputIface (view clientVty st)) - possibleTimedEvents = - [ (networkId, runAt, action) - | (networkId, cs) <- views clientConnections IntMap.toList st - , Just (runAt, action) <- [nextTimedAction cs] - ] - - earliestEvent - | null possibleTimedEvents = Nothing - | otherwise = Just (minimumBy (comparing (\(_,runAt,_) -> runAt)) possibleTimedEvents) - prepareTimer = - case earliestEvent of + case earliestEvent st of Nothing -> return retry - Just (networkId,runAt,action) -> + Just (networkId,(runAt,action)) -> do now <- getCurrentTime let microsecs = truncate (1000000 * diffUTCTime runAt now) var <- registerDelay (max 0 microsecs) @@ -97,27 +84,33 @@ unless ready retry return (TimerEvent networkId action) +-- | Compute the earliest scheduled timed action for the client +earliestEvent :: ClientState -> Maybe (NetworkId, (UTCTime, TimedAction)) +earliestEvent = + minimumByOf + (clientConnections . (ifolded <. folding nextTimedAction) . withIndex) + (comparing (fst . snd)) + -- | Apply this function to an initial 'ClientState' to launch the client. eventLoop :: ClientState -> IO () -eventLoop st0 = - do let st1 = clientTick st0 - vty = view clientVty st - (pic, st) = clientPicture st1 +eventLoop st = + do let vty = view clientVty st + when (view clientBell st) (beep vty) - -- check st0 for bell, it will be always be cleared in st1 - when (view clientBell st0) (beep vty) + let (pic, st') = clientPicture (clientTick st) update vty pic - event <- getEvent st + event <- getEvent st' case event of - TimerEvent networkId action -> doTimerEvent networkId action st - VtyEvent vtyEvent -> doVtyEvent vtyEvent st + TimerEvent networkId action -> eventLoop =<< doTimerEvent networkId action st' + VtyEvent vtyEvent -> traverse_ eventLoop =<< doVtyEvent vtyEvent st' NetworkEvent networkEvent -> + eventLoop =<< case networkEvent of - NetworkLine network time line -> doNetworkLine network time line st - NetworkError network time ex -> doNetworkError network time ex st - NetworkOpen network time -> doNetworkOpen network time st - NetworkClose network time -> doNetworkClose network time st + NetworkLine net time line -> doNetworkLine net time line st' + NetworkError net time ex -> doNetworkError net time ex st' + NetworkOpen net time -> doNetworkOpen net time st' + NetworkClose net time -> doNetworkClose net time st' -- | Sound the terminal bell assuming that the @BEL@ control code -- is supported. @@ -129,89 +122,92 @@ NetworkId {- ^ network id -} -> ZonedTime {- ^ event time -} -> ClientState {- ^ client state -} -> - IO () + IO ClientState doNetworkOpen networkId time st = case view (clientConnections . at networkId) st of Nothing -> error "doNetworkOpen: Network missing" Just cs -> - let msg = ClientMessage - { _msgTime = time - , _msgNetwork = view csNetwork cs - , _msgBody = NormalBody "connection opened" - } - in eventLoop $ recordNetworkMessage msg - $ overStrict (clientConnections . ix networkId . csLastReceived) - (\old -> old `seq` Just $! zonedTimeToUTC time) st + do let msg = ClientMessage + { _msgTime = time + , _msgNetwork = view csNetwork cs + , _msgBody = NormalBody "connection opened" + } + return $! recordNetworkMessage msg + $ overStrict (clientConnections . ix networkId . csLastReceived) + (\old -> old `seq` Just $! zonedTimeToUTC time) + st -- | Respond to a network connection closing normally. doNetworkClose :: - NetworkId {- ^ network id -} -> - ZonedTime {- ^ event time -} -> - ClientState -> IO () + NetworkId {- ^ network id -} -> + ZonedTime {- ^ event time -} -> + ClientState {- ^ client state -} -> + IO ClientState doNetworkClose networkId time st = - let (cs,st') = removeNetwork networkId st - msg = ClientMessage - { _msgTime = time - , _msgNetwork = view csNetwork cs - , _msgBody = NormalBody "connection closed" - } - in eventLoop $ recordNetworkMessage msg st' + do let (cs,st') = removeNetwork networkId st + msg = ClientMessage + { _msgTime = time + , _msgNetwork = view csNetwork cs + , _msgBody = NormalBody "connection closed" + } + return (recordNetworkMessage msg st') -- | Respond to a network connection closing abnormally. doNetworkError :: - NetworkId {- ^ failed network -} -> - ZonedTime {- ^ current time -} -> + NetworkId {- ^ failed network -} -> + ZonedTime {- ^ current time -} -> SomeException {- ^ termination reason -} -> - ClientState -> IO () + ClientState {- ^ client state -} -> + IO ClientState doNetworkError networkId time ex st = do let (cs,st1) = removeNetwork networkId st - st2 = foldl' (flip recordNetworkMessage) st1 msgs - - msgs = exceptionToLines ex <&> \e -> - ClientMessage - { _msgTime = time - , _msgNetwork = view csNetwork cs - , _msgBody = ErrorBody (Text.pack e) - } - - shouldReconnect = - case view csPingStatus cs of - PingConnecting n _ - | n == 0 || n > reconnectAttempts -> False + st2 = foldl' (\acc msg -> recordError time cs (Text.pack msg) acc) st1 + $ exceptionToLines ex + reconnectLogic ex cs st2 - _ | Just HostNotResolved{} <- fromException ex -> True - | Just HostCannotConnect{} <- fromException ex -> True - | Just PingTimeout <- fromException ex -> True - | Just ResourceVanished <- ioe_type <$> fromException ex -> True - | Just NoSuchThing <- ioe_type <$> fromException ex -> True +reconnectLogic :: + SomeException {- ^ thread failure reason -} -> + NetworkState {- ^ failed network -} -> + ClientState {- ^ client state -} -> + IO ClientState +reconnectLogic ex cs st - | otherwise -> False + | shouldReconnect = + do (attempts, mbDisconnectTime) <- computeRetryInfo + addConnection attempts mbDisconnectTime (view csNetwork cs) st + | otherwise = return st - reconnect = do - (attempts, mbDisconnectTime) - <- case view csPingStatus cs of - PingConnecting n tm -> pure (n+1, tm) - _ | Just tm <- view csLastReceived cs -> pure (1, Just tm) - | otherwise -> do now <- getCurrentTime - pure (1, Just now) - addConnection attempts mbDisconnectTime (view csNetwork cs) st2 + where + computeRetryInfo = + case view csPingStatus cs of + PingConnecting n tm -> pure (n+1, tm) + _ | Just tm <- view csLastReceived cs -> pure (1, Just tm) + | otherwise -> do now <- getCurrentTime + pure (1, Just now) - nextAction - | shouldReconnect = reconnect - | otherwise = return st2 + reconnectAttempts = view (csSettings . ssReconnectAttempts) cs - eventLoop =<< nextAction + shouldReconnect = + case view csPingStatus cs of + PingConnecting n _ | n == 0 || n > reconnectAttempts -> False + _ | Just HostNotResolved{} <- fromException ex -> True + | Just HostCannotConnect{} <- fromException ex -> True + | Just PingTimeout <- fromException ex -> True + | Just ResourceVanished <- ioe_type <$> fromException ex -> True + | Just NoSuchThing <- ioe_type <$> fromException ex -> True + | otherwise -> False -- | Respond to an IRC protocol line. This will parse the message, updated the -- relevant connection state and update the UI buffers. doNetworkLine :: - NetworkId {- ^ Network ID of message -} -> - ZonedTime {- ^ current time -} -> - ByteString {- ^ Raw IRC message without newlines -} -> - ClientState -> IO () + NetworkId {- ^ Network ID of message -} -> + ZonedTime {- ^ current time -} -> + ByteString {- ^ Raw IRC message without newlines -} -> + ClientState {- ^ client state -} -> + IO ClientState doNetworkLine networkId time line st = case view (clientConnections . at networkId) st of Nothing -> error "doNetworkLine: Network missing" @@ -219,13 +215,8 @@ let network = view csNetwork cs in case parseRawIrcMsg (asUtf8 line) of Nothing -> - do let txt = Text.pack ("Malformed message: " ++ show line) - msg = ClientMessage - { _msgTime = time - , _msgNetwork = network - , _msgBody = ErrorBody txt - } - eventLoop (recordNetworkMessage msg st) + do let msg = Text.pack ("Malformed message: " ++ show line) + return $! recordError time cs msg st Just raw -> do (st1,passed) <- clientPark st $ \ptr -> @@ -233,7 +224,7 @@ (view (clientExtensions . esActive) st) - if not passed then eventLoop st1 else do + if not passed then return st1 else do let time' = computeEffectiveTime time (view msgTags raw) @@ -245,10 +236,9 @@ messageHooks case stateHook (cookIrcMsg raw) of - Nothing -> eventLoop st1 -- Message ignored + Nothing -> return st1 -- Message ignored Just irc -> do traverse_ (sendMsg cs) replies - st3 <- clientResponse time' irc cs st2 - eventLoop st3 + clientResponse time' irc cs st2 where -- state with message recorded recSt = case viewHook irc of @@ -285,14 +275,14 @@ processConnectCmd :: ZonedTime {- ^ now -} -> NetworkState {- ^ current network -} -> - ClientState -> + ClientState {- ^ client state -} -> [ExpansionChunk]{- ^ command -} -> IO ClientState processConnectCmd now cs st0 cmdTxt = do dc <- forM disco $ \t -> Text.pack . formatTime defaultTimeLocale "%H:%M:%S" <$> utcToLocalZonedTime t - let failureCase = reportConnectCmdError now cs + let failureCase e = recordError now cs ("Bad connect-cmd: " <> e) case resolveMacroExpansions (commandExpansion dc st0) (const Nothing) cmdTxt of Nothing -> return $! failureCase "Unable to expand connect command" st0 Just cmdTxt' -> @@ -307,17 +297,17 @@ _ -> Nothing -reportConnectCmdError :: +recordError :: ZonedTime {- ^ now -} -> NetworkState {- ^ current network -} -> - Text {- ^ bad command -} -> - ClientState -> + Text {- ^ error message -} -> + ClientState {- ^ client state -} -> ClientState -reportConnectCmdError now cs cmdTxt = +recordError now cs msg = recordNetworkMessage ClientMessage { _msgTime = now , _msgNetwork = view csNetwork cs - , _msgBody = ErrorBody ("Bad connect-cmd: " <> cmdTxt) + , _msgBody = ErrorBody msg } -- | Find the ZNC provided server time @@ -342,7 +332,10 @@ -- | Respond to a VTY event. -doVtyEvent :: Event -> ClientState -> IO () +doVtyEvent :: + Event {- ^ vty event -} -> + ClientState {- ^ client state -} -> + IO (Maybe ClientState) {- ^ nothing when finished -} doVtyEvent vtyEvent st = case vtyEvent of EvKey k modifier -> doKey k modifier st @@ -350,19 +343,23 @@ do let vty = view clientVty st refresh vty (w,h) <- displayBounds (outputIface vty) - eventLoop $ set clientWidth w - $ set clientHeight h st + return $! Just $! set clientWidth w + $ set clientHeight h st EvPaste utf8 -> - let str = Text.unpack (Text.decodeUtf8With Text.lenientDecode utf8) - st' = over clientTextBox (Edit.insertPaste str) st - in eventLoop st' - _ -> eventLoop st + do let str = Text.unpack (Text.decodeUtf8With Text.lenientDecode utf8) + return $! Just $! over clientTextBox (Edit.insertPaste str) st + _ -> return (Just st) -- | Map keyboard inputs to actions in the client -doKey :: Key -> [Modifier] -> ClientState -> IO () +doKey :: + Key {- ^ key pressed -} -> + [Modifier] {- ^ modifiers held -} -> + ClientState {- ^ client state -} -> + IO (Maybe ClientState) doKey key modifier st = - let changeEditor f = eventLoop (over clientTextBox f st) + let continue !out = return (Just out) + changeEditor f = continue (over clientTextBox f st) changeContent f = changeEditor $ over Edit.content f . set Edit.lastOperation Edit.OtherOperation @@ -384,10 +381,11 @@ KChar '_' -> changeEditor (Edit.insert '\^_') KChar 'o' -> changeEditor (Edit.insert '\^O') KChar 'v' -> changeEditor (Edit.insert '\^V') - KChar 'p' -> eventLoop (retreatFocus st) - KChar 'n' -> eventLoop (advanceFocus st) - KChar 'l' -> refresh (view clientVty st) >> eventLoop st - _ -> eventLoop st + KChar 'p' -> continue (retreatFocus st) + KChar 'n' -> continue (advanceFocus st) + KChar 'l' -> do refresh (view clientVty st) + continue st + _ -> continue st [MMeta] -> case key of @@ -396,16 +394,18 @@ KChar 'd' -> changeEditor (Edit.killWordForward True) KChar 'b' -> changeContent Edit.leftWord KChar 'f' -> changeContent Edit.rightWord - KChar 'a' -> eventLoop (jumpToActivity st) - KChar 's' -> eventLoop (returnFocus st) + KLeft -> changeContent Edit.leftWord + KRight -> changeContent Edit.rightWord + KChar 'a' -> continue (jumpToActivity st) + KChar 's' -> continue (returnFocus st) KChar c | let names = clientWindowNames st , Just i <- elemIndex c names -> - eventLoop (jumpFocus i st) - _ -> eventLoop st + continue (jumpFocus i st) + _ -> continue st [] -> -- no modifier case key of - KEsc -> eventLoop (changeSubfocus FocusMessages st) + KEsc -> continue (changeSubfocus FocusMessages st) KBS -> changeContent Edit.backspace KDel -> changeContent Edit.delete KLeft -> changeContent Edit.left @@ -414,8 +414,8 @@ KEnd -> changeEditor Edit.end KUp -> changeEditor $ \ed -> fromMaybe ed $ Edit.earlier ed KDown -> changeEditor $ \ed -> fromMaybe ed $ Edit.later ed - KPageUp -> eventLoop (pageUp st) - KPageDown -> eventLoop (pageDown st) + KPageUp -> continue (scrollClient ( scrollAmount st) st) + KPageDown -> continue (scrollClient (-scrollAmount st) st) KEnter -> doCommandResult True =<< executeInput st KBackTab -> doCommandResult False =<< tabCompletion True st @@ -424,32 +424,43 @@ KChar c -> changeEditor (Edit.insert c) -- toggles - KFun 2 -> eventLoop (over clientDetailView not st) - KFun 3 -> eventLoop (over clientActivityBar not st) - KFun 4 -> eventLoop (over clientShowMetadata not st) + KFun 2 -> continue (over clientDetailView not st) + KFun 3 -> continue (over clientActivityBar not st) + KFun 4 -> continue (over clientShowMetadata not st) - _ -> eventLoop st + _ -> continue st - _ -> eventLoop st -- unsupported modifier + _ -> continue st -- unsupported modifier --- | Process 'CommandResult' by either running the 'eventLoop' with the --- new 'ClientState' or returning. -doCommandResult :: Bool -> CommandResult -> IO () + +-- | Process 'CommandResult' and update the 'ClientState' textbox +-- and error state. When quitting return 'Nothing'. +doCommandResult :: + Bool {- ^ clear on success -} -> + CommandResult {- ^ command result -} -> + IO (Maybe ClientState) doCommandResult clearOnSuccess res = + let continue !st = return (Just st) in case res of - CommandQuit st -> clientShutdown st - CommandSuccess st -> eventLoop (if clearOnSuccess then consumeInput st else st) - CommandFailure st -> eventLoop (set clientBell True st) + CommandQuit st -> Nothing <$ clientShutdown st + CommandSuccess st -> continue (if clearOnSuccess then consumeInput st else st) + CommandFailure st -> continue (set clientBell True st) -executeInput :: ClientState -> IO CommandResult + +-- | Execute the the command on the first line of the text box +executeInput :: + ClientState {- ^ client state -} -> + IO CommandResult executeInput st = execute (clientFirstLine st) st -- | Respond to a timer event. doTimerEvent :: - NetworkId {- ^ Network related to event -} -> - TimedAction {- ^ Action to perform -} -> - ClientState -> IO () + NetworkId {- ^ Network related to event -} -> + TimedAction {- ^ Action to perform -} -> + ClientState {- ^ client state -} -> + IO ClientState doTimerEvent networkId action = - eventLoop <=< traverseOf (clientConnections . ix networkId) - (applyTimedAction action) + traverseOf + (clientConnections . ix networkId) + (applyTimedAction action) diff --git a/src/Client/EventLoop/Errors.hs b/src/Client/EventLoop/Errors.hs --- a/src/Client/EventLoop/Errors.hs +++ b/src/Client/EventLoop/Errors.hs @@ -15,7 +15,6 @@ ) where import Control.Exception -import Data.Char import Data.List.NonEmpty (NonEmpty(..)) import Network.Connection import Network.TLS @@ -27,20 +26,10 @@ NonEmpty String {- ^ client lines -} exceptionToLines = indentMessages - . fmap cleanLine . exceptionToLines' indentMessages :: NonEmpty String -> NonEmpty String indentMessages (x :| xs) = x :| map ("⋯ "++) xs - -cleanLine :: String -> String -cleanLine = map clean1 - where - clean1 x - | x < '\x20' = chr (0x2400 + ord x) - | x == '\DEL' = '␡' - | isControl x = '�' - | otherwise = x exceptionToLines' :: SomeException {- ^ network error -} -> diff --git a/src/Client/Image.hs b/src/Client/Image.hs --- a/src/Client/Image.hs +++ b/src/Client/Image.hs @@ -9,7 +9,10 @@ This module provides the renderer for the client's UI. -} -module Client.Image (clientPicture) where +module Client.Image + ( clientPicture + , scrollAmount + ) where import Client.Image.Palette import Client.Image.StatusLine @@ -18,7 +21,6 @@ import Client.State.Focus import Client.View import Control.Lens -import Data.List import Graphics.Vty (Background(..), Picture(..), Cursor(..)) import Graphics.Vty.Image @@ -34,35 +36,52 @@ , picLayers = [img] } +-- | Primary UI render logic clientImage :: - ClientState -> - (Int, Image, ClientState) -- ^ text box cursor position, image, updated state -clientImage st = (pos, img, st'') + ClientState {- ^ client state -} -> + (Int, Image, ClientState) {- ^ text box cursor position, image, updated state -} +clientImage st = (pos, img, st') where - (st', mp) = messagePane mainHeight focus (view clientSubfocus st) st - (st'', extras) = mapAccumL renderExtra st' splits + (mainHeight, splitHeight) = clientWindowHeights (imageHeight activityBar) st + splitFocuses = clientExtraFocuses st + focus = view clientFocus st + (pos , tbImg ) = textboxImage st - (pos, tbImg) = textboxImage st'' - img = vertCat extras <-> - mp <-> - statusLineImage st'' <-> - tbImg + -- update client state for scroll clamp + st' = over clientScroll (max 0 . subtract overscroll) st - focus = view clientFocus st + (overscroll, msgs) = messagePane mainHeight focus (view clientSubfocus st) st + splits = renderExtra st' <$> splitFocuses + -- outgoing state is ignored here, splits don't get to truncate scrollback - (mainHeight, splitHeight) = clientWindowHeights st - splits = clientExtraFocuses st + img = vertCat splits <-> + msgs <-> + activityBar <-> + statusLineImage st' <-> + tbImg - renderExtra stIn focus1 = (stOut, outImg) + activityBar = activityBarImage st + -- must be st, not st', needed to compute window heights + -- before rendering the message panes + + renderExtra stIn focus1 = outImg where - (stOut,msgImg) = messagePane splitHeight focus1 FocusMessages stIn - pal = clientPalette st + (_,msgImg) = messagePane splitHeight focus1 FocusMessages stIn + pal = clientPalette stIn divider = view palWindowDivider pal - outImg = msgImg <-> minorStatusLineImage focus1 st - <-> charFill divider ' ' (view clientWidth st) 1 + outImg = msgImg <-> minorStatusLineImage focus1 stIn + <-> charFill divider ' ' (view clientWidth stIn) 1 -messagePane :: Int -> Focus -> Subfocus -> ClientState -> (ClientState, Image) -messagePane h focus subfocus st = (st', img) +-- | Generate an image corresponding to the image lines of the given +-- focus and subfocus. Returns the number of lines overscrolled to +-- assist in clamping scroll to the lines available in the window. +messagePane :: + Int {- ^ available rows -} -> + Focus {- ^ focused window -} -> + Subfocus {- ^ subfocus to render -} -> + ClientState {- ^ client state -} -> + (Int, Image) {- ^ overscroll, rendered messages -} +messagePane h focus subfocus st = (overscroll, img) where images = viewLines focus subfocus st vimg = assemble emptyImage images @@ -71,8 +90,6 @@ overscroll = vh - imageHeight vimg - st' = over clientScroll (max 0 . subtract overscroll) st - assemble acc _ | imageHeight acc >= vh = cropTop vh acc assemble acc [] = acc assemble acc (x:xs) = assemble (lineWrap w x <-> acc) xs @@ -82,9 +99,44 @@ w = view clientWidth st -lineWrap :: Int -> Image -> Image +-- | Given an image, break the image up into chunks of at most the +-- given width and stack the resulting chunks vertically top-to-bottom. +lineWrap :: + Int {- ^ maximum image width -} -> + Image {- ^ unwrapped image -} -> + Image {- ^ wrapped image -} lineWrap w img - | imageWidth img > w = cropRight w img <-> lineWrap w (cropLeft (imageWidth img - w) img) + | imageWidth img > w = cropRight w img <-> + lineWrap w (cropLeft (imageWidth img - w) img) | otherwise = img <|> char defAttr ' ' - -- trailing space with default attributes deals with bug in VTY - -- where the formatting will continue past the end of chat messages + -- trailing space with default attributes deals with bug in VTY + -- where the formatting will continue past the end of chat messages + + +-- | Compute the number of lines in a page at the current window size +scrollAmount :: + ClientState {- ^ client state -} -> + Int {- ^ scroll amount -} +scrollAmount st = max 1 (snd (clientWindowHeights actSize st)) + -- extra will be equal to main or 1 smaller + where + actSize = imageHeight (activityBarImage st) + + +-- | Number of lines to allocate for the focused window and the +-- main window. This doesn't include the textbox, activity bar, +-- or status line. +clientWindowHeights :: + Int {- ^ activity bar height -} -> + ClientState {- ^ client state -} -> + (Int,Int) {- ^ main height, extra height -} +clientWindowHeights activityBar st = + (max 0 (h - overhead - extras*d), max 0 (d-overhead)) + where + d = h `quot` (1 + extras) + + h = max 0 (view clientHeight st - activityBar) -- lines available + + extras = length (clientExtraFocuses st) + + overhead = 2 -- status line and textbox/divider diff --git a/src/Client/Image/Message.hs b/src/Client/Image/Message.hs --- a/src/Client/Image/Message.hs +++ b/src/Client/Image/Message.hs @@ -20,6 +20,7 @@ , quietIdentifier , coloredUserInfo , coloredIdentifier + , cleanText ) where import Client.Image.MircFormatting @@ -76,13 +77,23 @@ , bodyImage rm params body ] +cleanChar :: Char -> Char +cleanChar x + | x < '\x20' = chr (0x2400 + ord x) + | x == '\DEL' = '␡' + | isControl x = '�' + | otherwise = x + +cleanText :: Text -> Text +cleanText = Text.map cleanChar + errorImage :: MessageRendererParams -> Text {- ^ error message -} -> Image errorImage params txt = horizCat [ text' (view palError (rendPalette params)) "error " - , text' defAttr txt + , text' defAttr (cleanText txt) ] normalImage :: @@ -91,7 +102,7 @@ Image normalImage params txt = horizCat [ text' (view palLabel (rendPalette params)) "client " - , text' defAttr txt + , text' defAttr (cleanText txt) ] -- | Render the given time according to the current mode and palette. diff --git a/src/Client/Image/MircFormatting.hs b/src/Client/Image/MircFormatting.hs --- a/src/Client/Image/MircFormatting.hs +++ b/src/Client/Image/MircFormatting.hs @@ -170,4 +170,3 @@ (first, cntl:rest) -> Vty.string defAttr first Vty.<|> controlImage cntl Vty.<|> plainText rest - diff --git a/src/Client/Image/StatusLine.hs b/src/Client/Image/StatusLine.hs --- a/src/Client/Image/StatusLine.hs +++ b/src/Client/Image/StatusLine.hs @@ -1,4 +1,4 @@ -{-# Language BangPatterns #-} +{-# Language OverloadedStrings, BangPatterns #-} {-| Module : Client.Image.StatusLine Description : Renderer for status line @@ -14,6 +14,7 @@ module Client.Image.StatusLine ( statusLineImage , minorStatusLineImage + , activityBarImage ) where import Client.Image.Palette @@ -32,20 +33,20 @@ import Numeric -- | Renders the status line between messages and the textbox. -statusLineImage :: ClientState -> Image -statusLineImage st - = activityBar <-> - content <|> charFill defAttr '─' fillSize 1 +statusLineImage :: + ClientState {- ^ client state -} -> + Image {- ^ activity bar, status bar -} +statusLineImage st = content <|> charFill defAttr '─' fillSize 1 where fillSize = max 0 (view clientWidth st - imageWidth content) - (activitySummary, activityBar) = activityImages st content = horizCat [ myNickImage st , focusImage st - , activitySummary + , activitySummary st , detailImage st , nometaImage st , scrollImage st + , filterImage st , latencyImage st ] @@ -60,12 +61,20 @@ scrollImage :: ClientState -> Image scrollImage st | 0 == view clientScroll st = emptyImage - | otherwise = infoBubble - $ string attr "scroll" + | otherwise = infoBubble (string attr "scroll") where pal = clientPalette st attr = view palLabel pal +filterImage :: ClientState -> Image +filterImage st = + case clientActiveRegex st of + Nothing -> emptyImage + Just {} -> infoBubble (string attr "filtered") + where + pal = clientPalette st + attr = view palLabel pal + latencyImage :: ClientState -> Image latencyImage st | Just network <- views clientFocus focusNetwork st @@ -105,37 +114,53 @@ pal = clientPalette st attr = view palLabel pal -activityImages :: ClientState -> (Image, Image) -activityImages st = (summary, activityBar) +-- | Image for little box with active window names: +-- +-- @-[15p]@ +activitySummary :: ClientState -> Image +activitySummary st + | null indicators = emptyImage + | otherwise = string defAttr "─[" <|> + horizCat indicators <|> + string defAttr "]" where - activityBar - | view clientActivityBar st = activityBar' <|> activityFill - | otherwise = emptyImage + winNames = clientWindowNames st ++ repeat '?' - summary - | null indicators = emptyImage - | otherwise = string defAttr "─[" <|> - horizCat indicators <|> - string defAttr "]" + indicators = foldr aux [] (zip winNames windows) + windows = views clientWindows Map.elems st - activityFill = charFill defAttr '─' - (max 0 (view clientWidth st - imageWidth activityBar')) - 1 + aux (i,w) rest + | view winUnread w == 0 = rest + | otherwise = char attr i : rest + where + pal = clientPalette st + attr | view winMention w = view palMention pal + | otherwise = view palActivity pal - activityBar' = foldr baraux emptyImage - $ zip winNames +-- | Multi-line activity information enabled by F3 +activityBarImage :: ClientState -> Image +activityBarImage st + | view clientActivityBar st = activityBar' + | otherwise = emptyImage + where + activityBar' = makeLines (view clientWidth st) + $ catMaybes + $ zipWith baraux winNames $ Map.toList $ view clientWindows st - baraux (i,(focus,w)) rest - | n == 0 = rest - | otherwise = string defAttr "─[" <|> + winNames = clientWindowNames st ++ repeat '?' + + baraux i (focus,w) + | n == 0 = Nothing -- todo: make configurable + | otherwise = Just + $ string defAttr "─[" <|> char (view palWindowName pal) i <|> char defAttr ':' <|> text' (view palLabel pal) focusText <|> char defAttr ':' <|> string attr (show n) <|> - string defAttr "]" <|> rest + string defAttr "]" where n = view winUnread w pal = clientPalette st @@ -147,19 +172,25 @@ NetworkFocus net -> net ChannelFocus _ chan -> idText chan - windows = views clientWindows Map.elems st - winNames = clientWindowNames st ++ repeat '?' - indicators = foldr aux [] (zip winNames windows) - aux (i,w) rest - | view winUnread w == 0 = rest - | otherwise = char attr i : rest - where - pal = clientPalette st - attr | view winMention w = view palMention pal - | otherwise = view palActivity pal +makeLines :: + Int {- ^ window width -} -> + [Image] {- ^ components to pack -} -> + Image +makeLines _ [] = emptyImage +makeLines w (x:xs) = go x xs + where + go acc (y:ys) + | let acc' = acc <|> y + , imageWidth acc' <= w + = go acc' ys + + go acc ys = makeLines w ys + <-> acc <|> charFill defAttr '─' (max 0 (w - imageWidth acc)) 1 + + myNickImage :: ClientState -> Image myNickImage st = case view clientFocus st of @@ -238,16 +269,27 @@ viewSubfocusLabel pal subfocus = case subfocus of FocusMessages -> Nothing - FocusWindows -> Just $ string (view palLabel pal) "windows" + FocusWindows filt -> Just $ string (view palLabel pal) "windows" <|> + opt (windowFilterName filt) FocusInfo -> Just $ string (view palLabel pal) "info" FocusUsers -> Just $ string (view palLabel pal) "users" FocusMentions -> Just $ string (view palLabel pal) "mentions" FocusPalette -> Just $ string (view palLabel pal) "palette" FocusHelp mb -> Just $ string (view palLabel pal) "help" <|> - foldMap (\cmd -> char defAttr ':' <|> - text' (view palLabel pal) cmd) mb + opt mb FocusMasks m -> Just $ horizCat [ string (view palLabel pal) "masks" , char defAttr ':' , char (view palLabel pal) m ] + where + opt = foldMap (\cmd -> char defAttr ':' <|> + text' (view palLabel pal) cmd) + +windowFilterName :: WindowsFilter -> Maybe Text +windowFilterName x = + case x of + AllWindows -> Nothing + NetworkWindows -> Just "networks" + ChannelWindows -> Just "channels" + UserWindows -> Just "users" diff --git a/src/Client/Image/Textbox.hs b/src/Client/Image/Textbox.hs --- a/src/Client/Image/Textbox.hs +++ b/src/Client/Image/Textbox.hs @@ -118,7 +118,7 @@ allCommands = (Left <$> macros) <> (Right <$> commands) (attr, continue) = case recognize (Text.pack cmd) allCommands of - Exact (Right (Command spec _ _)) -> + Exact (Right Command{cmdArgumentSpec = spec}) -> ( specAttr spec , argumentsImage pal spec ) diff --git a/src/Client/Options.hs b/src/Client/Options.hs --- a/src/Client/Options.hs +++ b/src/Client/Options.hs @@ -17,6 +17,7 @@ -- * Lenses , optConfigFile , optInitialNetworks + , optNoConnect -- * Options loader , getOptions @@ -38,6 +39,7 @@ data Options = Options { _optConfigFile :: Maybe FilePath -- ^ configuration file path , _optInitialNetworks :: [Text] -- ^ initial networks + , _optNoConnect :: Bool -- ^ disable autoconnect , _optShowHelp :: Bool -- ^ show help message , _optShowVersion :: Bool -- ^ show version message } @@ -51,6 +53,7 @@ , _optInitialNetworks = [] , _optShowHelp = False , _optShowVersion = False + , _optNoConnect = False } -- | Option descriptions @@ -58,6 +61,8 @@ options = [ Option "c" ["config"] (ReqArg (set optConfigFile . Just) "PATH") "Configuration file path" + , Option "!" ["noconnect"] (NoArg (set optNoConnect True)) + "Disable autoconnecting" , Option "h" ["help"] (NoArg (set optShowHelp True)) "Show help" , Option "v" ["version"] (NoArg (set optShowVersion True)) diff --git a/src/Client/State.hs b/src/Client/State.hs --- a/src/Client/State.hs +++ b/src/Client/State.hs @@ -38,6 +38,7 @@ , clientConnection , clientBell , clientExtensions + , clientRegex -- * Client operations , withClientState @@ -45,7 +46,7 @@ , clientShutdown , clientPark , clientMatcher - , urlPattern + , clientActiveRegex , consumeInput , currentCompletionList @@ -60,9 +61,11 @@ , clientHighlights , clientWindowNames , clientPalette + , clientAutoconnects + , clientActiveCommand , clientExtraFocuses - , clientWindowHeights + , currentNickCompletionMode -- * Add messages to buffers , recordChannelMessage @@ -79,16 +82,19 @@ , jumpFocus -- * Scrolling - , pageUp - , pageDown + , scrollClient -- * Extensions , ExtensionState , esActive + -- * URL view + , urlPattern + ) where import Client.CApi +import Client.Commands.WordCompletion import Client.Configuration import Client.Configuration.ServerSettings import Client.Image.Message @@ -160,6 +166,7 @@ , _clientDetailView :: !Bool -- ^ use detailed rendering mode , _clientActivityBar :: !Bool -- ^ visible activity bar , _clientShowMetadata :: !Bool -- ^ visible activity bar + , _clientRegex :: (Maybe Regex) -- ^ optional persistent filter , _clientBell :: !Bool -- ^ sound a bell next draw @@ -234,6 +241,7 @@ , _clientScroll = 0 , _clientDetailView = False , _clientShowMetadata = True + , _clientRegex = Nothing , _clientActivityBar = view configActivityBar cfg , _clientNextConnectionId = 0 , _clientBell = False @@ -491,6 +499,13 @@ ++ channelUserList network chan st _ -> [] +-- | Returns the 'WordCompletionMode' associated with the current network. +currentNickCompletionMode :: ClientState -> WordCompletionMode +currentNickCompletionMode st = + fromMaybe defaultNickWordCompleteMode $ + do network <- views clientFocus focusNetwork st + preview (clientConnection network . csSettings . ssNickCompletion) st + networkChannelList :: Text {- ^ network -} -> ClientState -> @@ -506,23 +521,46 @@ channelUserList network channel = views (clientConnection network . csChannels . ix channel . chanUsers) HashMap.keys --- | Construct a text matching predicate used to filter the message window. clientMatcher :: ClientState -> Text -> Bool clientMatcher st = - case break (==' ') (clientFirstLine st) of - ("/grep" ,_:reStr) -> go True reStr - ("/grepi",_:reStr) -> go False reStr - ("/url" ,_ ) -> match urlPattern - _ -> const True + case clientActiveRegex st of + Nothing -> const True + Just r -> matchTest r + +-- | Construct a text matching predicate used to filter the message window. +clientActiveRegex :: ClientState -> Maybe Regex +clientActiveRegex st = + case clientActiveCommand st of + Just ("grep" ,reStr) -> go True reStr + Just ("grepi",reStr) -> go False reStr + _ -> case view clientRegex st of + Nothing -> Nothing + Just r -> Just r where go sensitive reStr = - case compile defaultCompOpt{caseSensitive=sensitive} defaultExecOpt reStr of - Left{} -> const True - Right r -> match r :: Text -> Bool + case compile defaultCompOpt{caseSensitive=sensitive} + defaultExecOpt{captureGroups=False} + reStr of + Left{} -> Nothing + Right r -> Just r + +-- | 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 + ('/':cmd,_:args) -> Just (cmd,args) + _ -> Nothing + + urlPattern :: Regex -urlPattern = makeRegex - ("https?://([[:alnum:]-]+\\.)*([[:alnum:]-]+)(:[[:digit:]]+)?(/[^[:space:]]*)"::String) +Right urlPattern = + compile + defaultCompOpt + defaultExecOpt{captureGroups=False} + "https?://([[:alnum:]-]+\\.)*([[:alnum:]-]+)(:[[:digit:]]+)?(/[^[:cntrl:][:space:]]*)" -- | Remove a network connection and unlink it from the network map. -- This operation assumes that the networkconnection exists and should @@ -577,7 +615,7 @@ IrcMsg {- ^ message recieved -} -> NetworkId {- ^ message network -} -> NetworkState {- ^ network connection state -} -> - ClientState -> + ClientState {- ^ client state -} -> ([RawIrcMsg], ClientState) {- ^ response , updated state -} applyMessageToClientState time irc networkId cs st = cs' `seq` (reply, st') @@ -656,21 +694,9 @@ -- Scrolling ------------------------------------------------------------------------ --- | Scroll the current buffer to show older messages -pageUp :: ClientState -> ClientState -pageUp st = over clientScroll (+ scrollAmount st) st - -- | Scroll the current buffer to show newer messages -pageDown :: ClientState -> ClientState -pageDown st = over clientScroll (max 0 . subtract (scrollAmount st)) st - --- | Compute the number of lines in a page at the current window size -scrollAmount :: ClientState -> Int -scrollAmount st = max 1 (min main extra) - where - (main,extra) = clientWindowHeights st - - +scrollClient :: Int -> ClientState -> ClientState +scrollClient amt = over clientScroll $ \n -> max 0 (n + amt) -- | List of extra focuses to display as split windows @@ -680,28 +706,7 @@ FocusMessages -> view clientFocus st `delete` view clientExtraFocus st _ -> [] --- | Number of lines to allocate for the focused window and the --- main window. This doesn't include the textbox, activity bar, --- or status line. -clientWindowHeights :: - ClientState {- ^ client state -} -> - (Int,Int) {- ^ main height, extra height -} -clientWindowHeights st = (max 0 (h - overhead - extras*d), max 0 (d-overhead)) - where - d = h `quot` (1 + extras) - h = max 0 (view clientHeight st - reservedLines) -- lines available - - extras = length (clientExtraFocuses st) - - overhead = 2 -- status line and textbox/divider - - reservedLines - | view clientActivityBar st = 1 -- activity bar - | otherwise = 0 - - - ------------------------------------------------------------------------ -- Focus Management ------------------------------------------------------------------------ @@ -727,7 +732,7 @@ | 0 <= i, i < Map.size windows = changeFocus focus st | otherwise = st where - windows = view clientWindows st + windows = view clientWindows st (focus,_) = Map.elemAt i windows -- | Change the window focus to the given value, reset the subfocus @@ -821,3 +826,10 @@ -- | Produce the list of window names configured for the client. clientPalette :: ClientState -> Palette clientPalette = view (clientConfig . configPalette) + +-- | Returns the list of network names that requested autoconnection. +clientAutoconnects :: ClientState -> [Text] +clientAutoconnects st = + [ network | (network, cfg) <- views (clientConfig . configServers) HashMap.toList st + , view ssAutoconnect cfg + ] diff --git a/src/Client/State/Focus.hs b/src/Client/State/Focus.hs --- a/src/Client/State/Focus.hs +++ b/src/Client/State/Focus.hs @@ -16,6 +16,7 @@ ( -- * Types Focus(..) , Subfocus(..) + , WindowsFilter(..) -- * Focus operations , focusNetwork @@ -46,7 +47,7 @@ | FocusInfo -- ^ Show channel metadata | FocusUsers -- ^ Show channel user list | FocusMasks !Char -- ^ Show channel mask list for given mode - | FocusWindows -- ^ Show client windows + | FocusWindows WindowsFilter -- ^ Show client windows | FocusPalette -- ^ Show current palette | FocusMentions -- ^ Show all mentions | FocusHelp (Maybe Text) -- ^ Show help window with optional command @@ -71,3 +72,11 @@ focusNetwork Unfocused = Nothing focusNetwork (NetworkFocus network) = Just network focusNetwork (ChannelFocus network _) = Just network + +-- | Filter argument for 'FocusWindows' +data WindowsFilter + = AllWindows -- ^ no filter + | NetworkWindows -- ^ only network windows + | ChannelWindows -- ^ only channel windows + | UserWindows -- ^ only user windows + deriving (Eq, Show) diff --git a/src/Client/State/Network.hs b/src/Client/State/Network.hs --- a/src/Client/State/Network.hs +++ b/src/Client/State/Network.hs @@ -64,6 +64,11 @@ , TimedAction(..) , nextTimedAction , applyTimedAction + + -- * Moderation + , useChanServ + , sendModeration + , sendTopic ) where import Client.Configuration.ServerSettings @@ -820,3 +825,48 @@ sendMsg cs (ircPing ["ping"]) return $! set csNextPingTime (Just $! addUTCTime 60 now) $ set csPingStatus (PingSent now) cs + +------------------------------------------------------------------------ +-- Moderation +------------------------------------------------------------------------ + +-- | Used to send commands that require ops to perform. +-- If this channel is one that the user has chanserv access and ops are needed +-- then ops are requested and the commands are queued, otherwise send them +-- directly. +sendModeration :: + Identifier {- ^ channel -} -> + [RawIrcMsg] {- ^ commands -} -> + NetworkState {- ^ network state -} -> + IO NetworkState +sendModeration channel cmds cs + | useChanServ channel cs = + do let cmd = ircPrivmsg "ChanServ" (Text.unwords ["OP", idText channel]) + sendMsg cs cmd + return $ csChannels . ix channel . chanQueuedModeration <>~ cmds $ cs + | otherwise = cs <$ traverse_ (sendMsg cs) cmds + +useChanServ :: + Identifier {- ^ channel -} -> + NetworkState {- ^ network state -} -> + Bool {- ^ chanserv available -} +useChanServ channel cs = + channel `elem` view (csSettings . ssChanservChannels) cs && + not (iHaveOp channel cs) + +sendTopic :: + Identifier {- ^ channel -} -> + Text {- ^ topic -} -> + NetworkState {- ^ network state -} -> + IO () +sendTopic channelId topic cs = sendMsg cs cmd + where + chanservTopicCmd = + ircPrivmsg + "ChanServ" + (Text.unwords ["TOPIC", idText channelId, topic]) + + cmd + | Text.null topic = ircTopic channelId "" + | useChanServ channelId cs = chanservTopicCmd + | otherwise = ircTopic channelId topic diff --git a/src/Client/View.hs b/src/Client/View.hs --- a/src/Client/View.hs +++ b/src/Client/View.hs @@ -21,6 +21,7 @@ import Client.View.Mentions import Client.View.Messages import Client.View.Palette +import Client.View.UrlSelection import Client.View.UserList import Client.View.Windows import Control.Lens @@ -29,6 +30,7 @@ viewLines :: Focus -> Subfocus -> ClientState -> [Image] viewLines focus subfocus !st = case (focus, subfocus) of + _ | Just ("url",_) <- clientActiveCommand st -> urlSelectionView focus st (ChannelFocus network channel, FocusInfo) -> channelInfoImages network channel st (ChannelFocus network channel, FocusUsers) @@ -36,11 +38,10 @@ | otherwise -> userListImages network channel st (ChannelFocus network channel, FocusMasks mode) -> maskListImages mode network channel st - (_, FocusWindows) -> windowsImages st + (_, FocusWindows filt) -> windowsImages filt st (_, FocusMentions) -> mentionsViewLines st (_, FocusPalette) -> paletteViewLines pal (_, FocusHelp mb) -> helpImageLines mb pal - _ -> chatMessageImages focus st where pal = clientPalette st diff --git a/src/Client/View/Help.hs b/src/Client/View/Help.hs --- a/src/Client/View/Help.hs +++ b/src/Client/View/Help.hs @@ -1,4 +1,4 @@ -{-# Language OverloadedStrings #-} +{-# Language BangPatterns, OverloadedStrings #-} {-| Module : Client.View.Help @@ -21,6 +21,8 @@ import Client.Image.Palette import Client.Commands.Recognizer import Control.Lens +import Data.Foldable (toList) +import Data.List (delete) import Data.List.NonEmpty (NonEmpty((:|))) import Data.Monoid ((<>)) import Data.Text (Text) @@ -51,14 +53,20 @@ [string (view palError pal) $ "Unknown command, did you mean: " ++ suggestions] where suggestions = Text.unpack $ Text.intercalate " " ((cmdName <>) <$> sfxs) - Exact (Command args doc impl) -> - reverse $ commandSummary pal (pure cmdName) args + Exact Command{cmdNames = names, cmdImplementation = impl, + cmdArgumentSpec = spec, cmdDocumentation = doc} -> + reverse $ commandSummary pal (pure cmdName) spec : emptyImage - : explainContext impl + : aliasLines + ++ explainContext impl : emptyImage - : map parseIrcText docs + : map parseIrcText (Text.lines doc) where - docs = Text.lines doc + aliasLines = + case delete cmdName (toList names) of + [] -> [] + ns -> [ text' defAttr (Text.unwords ("Aliases:":ns)) + , emptyImage ] -- | Generate an explanation of the context where the given command -- implementation will be valid. @@ -81,8 +89,8 @@ [Image] {- ^ help lines -} listAllCommands pal = reverse - [ commandSummary pal name args - | (name, Command args _ _) <- commandsList ] + [ commandSummary pal names spec + | Command{ cmdNames = names, cmdArgumentSpec = spec } <- commandsList ] -- | Generate the help line for the given command and its -- specification for use in the list of commands. diff --git a/src/Client/View/UrlSelection.hs b/src/Client/View/UrlSelection.hs new file mode 100644 --- /dev/null +++ b/src/Client/View/UrlSelection.hs @@ -0,0 +1,37 @@ +{-# Language BangPatterns #-} +{-| +Module : Client.View.UrlSelection +Description : URL selection module +Copyright : (c) Eric Mertens, 2016 +License : ISC +Maintainer : emertens@gmail.com + +This module provides a list of the URLs found in the current message +window in order to assist in selecting one to open with @/url@ + +-} +module Client.View.UrlSelection + ( urlSelectionView + ) where + +import Client.State +import Client.State.Window +import Client.State.Focus +import Client.Image.Message +import Control.Lens +import Graphics.Vty.Image +import Text.Regex.TDFA +import Data.Text (Text) + + +urlSelectionView :: Focus -> ClientState -> [Image] +urlSelectionView focus st = + zipWith draw [1..] + $ toListOf (clientWindows . ix focus . winMessages . folded . wlText . folding textUrls) st + +textUrls :: Text -> [Text] +textUrls = getAllTextMatches . match urlPattern + +draw :: Int -> Text -> Image +draw i url = string defAttr (shows i ". ") + <|> text' defAttr (cleanText url) diff --git a/src/Client/View/Windows.hs b/src/Client/View/Windows.hs --- a/src/Client/View/Windows.hs +++ b/src/Client/View/Windows.hs @@ -16,6 +16,7 @@ import Client.State import Client.State.Focus import Client.State.Window +import Client.State.Network import Control.Lens import Data.List import qualified Data.Map as Map @@ -23,23 +24,49 @@ import Irc.Identifier -- | Draw the image lines associated with the @/windows@ command. -windowsImages :: ClientState -> [Image] -windowsImages st - = reverse - $ createColumns - $ zipWith (renderWindowColumns pal) names windows +windowsImages :: WindowsFilter -> ClientState -> [Image] +windowsImages filt st = reverse (createColumns windows) where - windows = views clientWindows Map.toAscList st + windows = [ renderWindowColumns pal n k v + | (n,(k,v)) <- zip names + $ views clientWindows Map.toAscList st + , windowMatcher filt st k + ] pal = clientPalette st names = clientWindowNames st ++ repeat '?' -renderWindowColumns :: Palette -> Char -> (Focus, Window) -> [Image] -renderWindowColumns pal name (focus, win) = + +------------------------------------------------------------------------ + +windowMatcher :: WindowsFilter -> ClientState -> Focus -> Bool + +windowMatcher AllWindows _ _ = True + +windowMatcher NetworkWindows _ NetworkFocus{} = True + +windowMatcher ChannelWindows st (ChannelFocus net chan) = + case preview (clientConnection net) st of + Just cs -> isChannelIdentifier cs chan + Nothing -> True + +windowMatcher UserWindows st (ChannelFocus net chan) = + case preview (clientConnection net) st of + Just cs -> not (isChannelIdentifier cs chan) + Nothing -> True + +windowMatcher _ _ _ = False + +------------------------------------------------------------------------ + + +renderWindowColumns :: Palette -> Char -> Focus -> Window -> [Image] +renderWindowColumns pal name focus win = [ char (view palWindowName pal) name , renderedFocus pal focus , renderedWindowInfo pal win ] + createColumns :: [[Image]] -> [Image] createColumns xs = map makeRow xs diff --git a/src/Config/FromConfig.hs b/src/Config/FromConfig.hs --- a/src/Config/FromConfig.hs +++ b/src/Config/FromConfig.hs @@ -43,6 +43,7 @@ import Control.Monad.Trans.State import Data.HashMap.Strict (HashMap) import qualified Data.HashMap.Strict as HashMap +import qualified Data.HashSet as HashSet import Data.Monoid import Data.Ratio import Data.Text (Text) @@ -100,6 +101,15 @@ n = floatingToRatio c e parseConfig _ = failure "expected integral number" +instance FromConfig Int where + parseConfig v = + do i <- parseConfig v + let small = minBound :: Int + large = maxBound :: Int + when (i < toInteger small || toInteger large < i) + (failure "int out of range") + return (fromInteger i) + -- | Matches 'Number' values ignoring the base instance Integral a => FromConfig (Ratio a) where parseConfig (Number _ n) = return $! fromIntegral n @@ -133,7 +143,8 @@ -- of the sections from that value. parseSections :: SectionParser a -> Value -> ConfigParser a parseSections (SectionParser p) (Sections xs) = - do (res, xs') <- runStateT p (toHashMap xs) + do hm <- toHashMap xs + (res, xs') <- runStateT p hm let unused = HashMap.keys xs' unless (null unused) (failure ("unknown keys: " <> Text.intercalate ", " unused)) @@ -168,8 +179,19 @@ Nothing -> failure ("section required: " <> key) Just x -> return x -toHashMap :: [Section] -> HashMap Text Value -toHashMap xs = HashMap.fromList [ (k,v) | Section k v <- xs ] -- todo: handle duplicate sections +toHashMap :: [Section] -> ConfigParser (HashMap Text Value) +toHashMap xs = + case duplicateCheck xs of + Just key -> failure ("duplicate section: " <> key) + Nothing -> return $! HashMap.fromList [ (k,v) | Section k v <- xs ] + +duplicateCheck :: [Section] -> Maybe Text +duplicateCheck = go HashSet.empty + where + go _ [] = Nothing + go seen (Section x _:xs) + | HashSet.member x seen = Just x + | otherwise = go (HashSet.insert x seen) xs floatingToRatio :: Integral a => Integer -> Integer -> Ratio a floatingToRatio c e = fromIntegral c * 10 ^^ e