diff --git a/CHANGELOG.md b/CHANGELOG.md --- a/CHANGELOG.md +++ b/CHANGELOG.md @@ -1,3 +1,80 @@ +50200.2.0 +========= + +New features: + * Channel scrolling mode has been merged with message select mode. + There are no longer two separate modes that the user must switched + between for fetching additional messages and operating on displayed + messages. + * As part of this change, gaps in the local client history where + the server may contain additional messages are displayed as + special entries in the message history, along with specific key + commands that can be used to fetch additional messages at that + point. + * The `/msg` command now takes optional user and message arguments to + make it faster and easier to initiate discussions with specific + users: `/msg [@user [message]]`. This resolves enhancement issue + #471. + * If smart editing is enabled and a triple backtick is typed at the + start of a line, input automatically switches to multi-line mode. + Fixes issue #467. + * Status is now tracked on a per-channel basis. Previously some + things (like incomplete message entries) were global, and others + were simply reset when moving away from and back to a channel. In + this version, much of this state is automatically saved and + restored on a per-channel basis: + * Incomplete message (editor) entries. + * Multi-line mode for incomplete message entries. + * Input history scrollback position. + * Incomplete message reply-to or editing-previous-post status. + This resolves enhancement issue #445. + * Adds the `/user` command as an alias for the `/msg` command. + * Channel auto-completion mode indication of the user's membership in + the channel is more clearly indicated. + * A new configuration item (`directChannelExpirationDays`) is added. + In release 50200.1.0, the channel sidebar management was updated to + automatically remove direct channels if there had been no activity + for 7 days. This configuration item allows overriding that time + period, (thanks, Brent Carmer). + * A new configuration item (`cpuUsagePolicy`) is added. Valid values + are `single` and `multiple` which determines how many of the + available processors Matterhorn will make use of. The default is + `multiple`. This resolves enhancement issue #484. + * Additional information on managing attachments (relative to issue #485). + +New command-line options: + * `-k`: print the active keybindings in plain text format. The output + includes customized bindings in the current configuration, or the + defaults if `-i` is used. + * `-K`: print the active keybindings in Markdown format. The output + includes customized bindings in the current configuration, or the + defaults if `-i` is used. + +Documentation updates: + * The FAQ is updated to help users with terminals that don't support + hyperlinks (thanks, Bob Arezina). + * Updated the Design notes and development Practices documentation + for Matterhorn. + * Matterhorn releases now include the default keybindings in a Markdown + document, `keybindings.md`. + +Bug fixes: + * Updated to mattermost-api 50200.1.2 which includes a bugfix for a + server "UploadResponse" with a null `client_ids` field. This + manifested as an error report when attempting to post a message + with an attachment to a general channel. + * Misc process and maintenance changes to re-enable and update the + Travis builds (fully passing now). + +Dependency updates: + * Added support for building with GHC 8.6 (thanks, Adam Wick). + +50200.1.2 +========= + +Bug fixes: + * Permit user creation timestamp to be optional in server responses + (#483) 50200.1.1 ========= diff --git a/PRACTICES.md b/PRACTICES.md --- a/PRACTICES.md +++ b/PRACTICES.md @@ -13,11 +13,70 @@ * We want to manage inevitable software evolution, and * We want to reduce waste through good team coordination. -General -------- +Design Philosophy +----------------- -Branches should be `-Wall` clean prior to merging. +We aim to take care of the following concerns when adding new features: + * We want Matterhorn to be responsive. + * We want Matterhorn to use available system resources when possible. + * We want Matterhorn's system resource usage to be user-constrainable. + * We want Matterhorn to default to using only as much system resources + as necessary. + * We want to avoid exposing or leaking Haskell internals (such as RTS + options) to the end user. Instead, we want to use our own idioms. + * We want configuration to be as clear, simple, and future-proof as + possible. (Avoid: confusing, complex, error-prone, future-brittle.) + +Commit Hygiene +-------------- + +Before committing or merging, strive for a `-Wall`-clean build. + +Each commit should ideally make one logical, self-contained change. For +example, by this reasoning a commit should add one new feature, fix one +bug, or do one incremental refactoring step. A single commit maintains +a successful build and working software whenever possible. Commits that +break things that are intended to be fixed at a much later date should +be avoided if possible. When unavoidable they should be indicated very +clearly by their commit message. + +Commits should also be concise so that if something has to be reverted +or updated it's easy to focus on the origin of the change in its +minimum form. Commits should not be squashed (no mega-commits, please). + +A commit should have a commit message describing the purpose of the +change, the salient code elements to bring to the reader's attention, +any motivations or context for the change, any caveats, and any +intentions about the future. A good commit message template is: + +``` +: + + +``` + +where `scope` is the name of a module, file, function, etc. that plays +the most central role in the change. + +We want commit messages to be a good reference for someone (maybe you!) +wanting to understand a code change (maybe your own!) in the future. +Capturing reasoning and other context makes the commit history useful in +this way. + +One way to support this workflow is to always use hunk prompting with +git: + +``` +$ git add -p +``` + +and only add hunks relevant to your logical change and split large hunks +into small ones with the `s` choice to ensure that incidental unrelated +changes don't make it into the commit. You should only ever use `git +add ` if you are *absolutely sure* the entire file belongs in the +commit. + Aesthetics ---------- @@ -94,6 +153,33 @@ directly to `master` and merged back into `develop`. This ensures that bug fixes are not held up by other development work in case a bugfix release is desired. + +Compatibility +------------- + +Matterhorn is primarily distributed to users as binaries that have +been built for that purpose; the primary compatibility support goal is +the set of operating systems binaries are built for. + +From an operating system perspective, the "current stable release" +versions of those operating systems are the primary targets. We +support many of the more popular operating systems, including: CentOS, +Fedoria, Ubuntu, and MacOS. + +Those wishing to use Matterhorn on a different operating system (that +is not compatible with one of the pre-built binaries) or work with the +code directly by building from source will need to obtain the source +directly and follow the build instructions described in the README +document. The GHC compiler version documented in the build +instructions is the primary supported version. + +Continuous Integration (CI) systems (e.g. Travis and/or Hydra) are +used for determining the viability of builds for different GHC +compiler versions, and in some cases on different operating systems. +The general intent is to support 3 GHC compiler versions (the current +and the two most previous versions) to allow flexibility for developer +configurations, but we cannot commit to supporting any version other +than the one documented in the README. Issue Tracking -------------- diff --git a/README.md b/README.md --- a/README.md +++ b/README.md @@ -29,8 +29,12 @@ https://github.com/matterhorn-chat/matterhorn/releases To run Matterhorn, unpack the binary release archive and run the -`matterhorn` binary within. +`matterhorn` binary within. Help is available via the `--help` or +`-h` flag. + $ matterhorn --help + $ matterhorn + When you run Matterhorn you'll be prompted for your server information and credentials. At present `matterhorn` supports only username/password authentication. @@ -71,16 +75,26 @@ * Bottom: editing area for writing, editing, and replying to messages You can use built-in keybindings or `/cmd`-style commands to operate -the client. To see available keybindings and commands, use the default -binding of `F1` or run the `/help` command. Keybindings may include -modifiers such as Control (indicated with a `C-` prefix) or Meta -(indicated with a `M-` prefix). If your keyboard has an `Alt` key, that -will work as `Meta`. If it does not, you may be able to configure your -terminal to provide `Meta` via other means (e.g. iTerm2 on OS X can be -configured to make the left Option key work as Meta). Keybindings can -be customized in the configuration file; see `/help keybindings` for -details. +the client. Keybinding information may be obtained in a number of ways: +* The `/help` command within Matterhorn. +* The `F1` key within Matterhorn. +* Running matterhorn with the `-k` argument for text keybindings +* Running matterhorn with the `-K` argument for [Markdown keybindings](keybindings.md) + + Note: The latter two commands do not start the client but simply + print to stdout and exit. The bindings shown include any user + overrides from the config files; use the `-i` flag to skip loading + the local config files and see the Matterhorn default keybindings. + +Keybindings may include modifiers such as Control (indicated with a +`C-` prefix) or Meta (indicated with a `M-` prefix). If your keyboard +has an `Alt` key, that will work as `Meta`. If it does not, you may be +able to configure your terminal to provide `Meta` via other means +(e.g. iTerm2 on OS X can be configured to make the left Option key +work as Meta). Keybindings can be customized in the configuration +file; see `/help keybindings` for details. + To join a channel, use the `/join` command to choose from a list of available channels. To create a channel, use `/create-channel`. To leave a channel, use `/leave-channel`. @@ -213,15 +227,43 @@ # Our Versioning Scheme Matterhorn version strings will be of the form `ABBCC.X.Y` where ABBCC -corresponds to the Mattermost server version supported by the release. -For example, if a release supports Mattermost server version 1.2.3, the -ABBCC portion of the `matterhorn` version will be `10203`. The `X.Y` -portion of the version corresponds to our own version namespace for the -package. If the server version changes, `X.Y` SHOULD be `0.0`. Otherwise -the first component should increment if the package undergoes major code -changes or functionality changes. The second component alone should -change only if the package undergoes security fixes or other bug fixes. +corresponds to the lowest Mattermost server version expected to be +supported by the release. For example, if a release supports +Mattermost server version 1.2.3, the ABBCC portion of the `matterhorn` +version will be `10203`. There may be later versions of the +Mattermost server that are supported (e.g. Matterhorn 50200.X.Y +supports Mattermost server versions 5.2 through at least 5.8). +The `X.Y` portion of the version corresponds to our own version +namespace for the package. If the server version changes, `X.Y` SHOULD +be `0.0`. Otherwise the first component should increment if the +package undergoes major code changes or functionality changes. The +second component alone should change only if the package undergoes +security fixes or other bug fixes. + +# Our Design Philosophy + +Overall, we strive to build a terminal client that provides the same +basic feature set as the web client. This is reflected in the state +of the client, our issue backlog, and the content of our wiki feature +design discussions. + +We intend to add web client features to Matterhorn to the extent that +they can be added sensibly in a terminal setting. Our goal is to do +so in a way that minimizes surprise to web client users migrating to +Matterhorn while also providing the best terminal user experience that +we can think of. That might entail adding the web client features but +changing their designs to ones better suited for terminal use or it +might mean omitting aspects of web client features that rely heavily on +mouse- or DOM-related UI idioms. It might also entail adding web client +features but deviating slightly on specific behaviors. + +If you are used to a web client feature and don't see it in Matterhorn, +that's probably because we just haven't gotten to it yet. We would +be happy to hear from people wanting to contribute! If you can't +contribute, search existing issues to see if we already have an issue +for it, or create a new issue and let us know! + # Contributing If you decide to contribute, that's great! Here are some guidelines you @@ -253,3 +295,7 @@ * http://www.nerdyweekly.com/posts/enable-italic-text-vim-tmux-gnome-terminal/ * https://medium.com/@dubistkomisch/how-to-actually-get-italics-and-true-colour-to-work-in-iterm-tmux-vim-9ebe55ebc2be * https://github.com/tmux/tmux/blob/2.1/FAQ#L355-L383 + +* Q: I am seeing malformed characters when I run matterhorn in my terminal. What could be causing this? +* A: Some terminal emulators cannot handle the extra escaping that occurs when the URL hyperlinking mode + is enabled. Try setting `hyperlinkUrls = False` in your `config.ini` file. diff --git a/matterhorn.cabal b/matterhorn.cabal --- a/matterhorn.cabal +++ b/matterhorn.cabal @@ -1,5 +1,5 @@ name: matterhorn -version: 50200.1.1 +version: 50200.2.0 synopsis: Terminal client for the Mattermost chat system description: This is a terminal client for the Mattermost chat system. Please see the README for a list of @@ -8,11 +8,11 @@ license-file: LICENSE author: matterhorn@galois.com maintainer: matterhorn@galois.com -copyright: ©2016-2018 AUTHORS.txt +copyright: ©2016-2019 AUTHORS.txt category: Chat build-type: Simple cabal-version: >= 1.18 -tested-with: GHC == 7.10.3, GHC == 8.0.1 +tested-with: GHC == 7.10.3, GHC == 8.0.1, GHC == 8.2.2, GHC == 8.4.4, GHC == 8.6.3 data-files: syntax/*.xml syntax/language.dtd @@ -43,7 +43,6 @@ State.Attachments State.Autocomplete State.Channels - State.ChannelScroll State.ChannelSelect State.Common State.Editing @@ -87,7 +86,6 @@ Events.MessageSelect Events.Main Events.JoinChannel - Events.ChannelScroll Events.ChannelSelect Events.PostListOverlay Events.UrlSelect @@ -108,6 +106,7 @@ Types.KeyEvents Types.Messages Types.Users + Types.UserNames Types.Posts FilePaths TeamSelect @@ -119,22 +118,22 @@ default-extensions: OverloadedStrings, ScopedTypeVariables, NoImplicitPrelude - ghc-options: -Wall -threaded -with-rtsopts=-I0 + ghc-options: -Wall -threaded -with-rtsopts=-I0 -Wcompat build-depends: base >=4.8 && <5 - , mattermost-api == 50200.1.0 + , mattermost-api == 50200.1.2 , base-compat >= 0.9 && < 0.11 , unordered-containers >= 0.2 && < 0.3 - , containers >= 0.5.7 && < 0.6 + , containers >= 0.5.7 && < 0.7 , data-clist >= 0.1.2 && < 0.2 , semigroups >= 0.18 && < 0.19 , connection >= 0.2 && < 0.3 , text >= 1.2 && < 1.3 , bytestring >= 0.10 && < 0.11 - , stm >= 2.4 && < 2.5 + , stm >= 2.4 && < 2.6 , config-ini >= 0.2.2.0 && < 0.3 , process >= 1.4 && < 1.7 , microlens-platform >= 0.3 && < 0.4 - , brick >= 0.43 && < 0.44 + , brick >= 0.46 && < 0.47 , brick-skylighting >= 0.2 && < 0.4 , vty >= 5.23.1 && < 5.26 , word-wrap >= 0.4.0 && < 0.5 @@ -159,7 +158,7 @@ , skylighting-core >= 0.7 && < 0.8 , timezone-olson >= 0.1.7 && < 0.2 , timezone-series >= 0.1.6.1 && < 0.2 - , aeson >= 1.2.3.0 && < 1.4 + , aeson >= 1.2.3.0 && < 1.5 , async >= 2.2 && < 2.3 , uuid >= 1.3 && < 1.4 , random >= 1.1 && < 1.2 @@ -173,37 +172,38 @@ , TimeUtils , Types.Messages , Types.Posts + , Types.UserNames , Types.Common , Types.DirectionalSeq , Prelude.MH default-language: Haskell2010 default-extensions: OverloadedStrings , ScopedTypeVariables - ghc-options: -Wall -fno-warn-orphans + ghc-options: -Wall -fno-warn-orphans -Wcompat hs-source-dirs: src, test build-depends: base >=4.7 && <5 , base-compat >= 0.9 && < 0.11 - , brick >= 0.43 && < 0.44 + , brick >= 0.46 && < 0.47 , bytestring >= 0.10 && < 0.11 , cheapskate >= 0.1 && < 0.2 , checkers >= 0.4 && < 0.5 , config-ini >= 0.2.2.0 && < 0.3 , connection >= 0.2 && < 0.3 - , containers >= 0.5.7 && < 0.6 + , containers >= 0.5.7 && < 0.7 , directory >= 1.3 && < 1.4 , filepath >= 1.4 && < 1.5 , hashable >= 1.2 && < 1.3 , Hclip >= 3.0 && < 3.1 - , mattermost-api == 50200.1.0 - , mattermost-api-qc == 50200.1.0 + , mattermost-api == 50200.1.2 + , mattermost-api-qc == 50200.1.2 , microlens-platform >= 0.3 && < 0.4 , mtl >= 2.2 && < 2.3 , process >= 1.4 && < 1.7 , quickcheck-text >= 0.1 && < 0.2 - , stm >= 2.4 && < 2.5 + , stm >= 2.4 && < 2.6 , strict >= 0.3 && < 0.4 , string-conversions >= 0.4 && < 0.5 - , tasty >= 0.11 && < 1.2 + , tasty >= 0.11 && < 1.3 , tasty-hunit >= 0.9 && < 0.12 , tasty-quickcheck >= 0.8 && < 0.12 , text >= 1.2 && < 1.3 @@ -214,7 +214,7 @@ , transformers >= 0.4 && < 0.6 , Unique >= 0.4 && < 0.5 , unordered-containers >= 0.2 && < 0.3 - , vector <= 0.12.0.1 + , vector < 0.13 , vty >= 5.23.1 && < 5.26 , xdg-basedir >= 0.2 && < 0.3 , semigroups >= 0.18 && < 0.19 diff --git a/src/App.hs b/src/App.hs --- a/src/App.hs +++ b/src/App.hs @@ -11,6 +11,7 @@ import Control.Monad.Trans.Except ( runExceptT ) import qualified Graphics.Vty as Vty import Text.Aspell ( stopAspell ) +import GHC.Conc (getNumProcessors, setNumCapabilities) import Network.Mattermost @@ -38,8 +39,23 @@ , appAttrMap = (^.csResources.crTheme) } +applicationMaxCPUs :: Int +applicationMaxCPUs = 2 + +setupCpuUsage :: Config -> IO () +setupCpuUsage config = do + actualNumCpus <- getNumProcessors + + let requestedCPUs = case configCpuUsagePolicy config of + SingleCPU -> 1 + MultipleCPUs -> min applicationMaxCPUs actualNumCpus + + setNumCapabilities requestedCPUs + runMatterhorn :: Options -> Config -> IO ChatState runMatterhorn opts config = do + setupCpuUsage config + st <- setupState (optLogLocation opts) config let mkVty = do diff --git a/src/Command.hs b/src/Command.hs --- a/src/Command.hs +++ b/src/Command.hs @@ -25,12 +25,14 @@ import HelpTopics import Scripts import State.Help +import State.Editing import State.Channels import State.ChannelSelect import State.Logging import State.PostListOverlay import State.Themes import State.UserListOverlay +import State.Users import Types @@ -86,8 +88,8 @@ beginCurrentChannelDeleteConfirm , Cmd "hide" "Hide the current DM or group channel from the channel list" - NoArg $ \ () -> - hideCurrentDMChannel + NoArg $ \ () -> do + hideDMChannel =<< use csCurrentChannelId , Cmd "reconnect" "Force a reconnection attempt to the server" NoArg $ \ () -> @@ -121,10 +123,22 @@ NoArg $ \ () -> enterChannelInviteUserList - , Cmd "msg" "Chat with a user privately" + , Cmd "msg" "Search for a user to enter a private chat" NoArg $ \ () -> enterDMSearchUserList + , Cmd "msg" "Chat with the specified user" + (TokenArg "user" NoArg) $ \ (name, ()) -> + changeChannelByName name + + , Cmd "msg" "Go to a user's channel and send the specified message" + (TokenArg "user" $ LineArg "message") $ \ (name, msg) -> do + withFetchedUserMaybe (UserFetchByUsername name) $ \foundUser -> do + case foundUser of + Just user -> createOrFocusDMChannel user $ Just $ \cId -> + handleInputSubmission cId msg + Nothing -> mhError $ NoSuchUser name + , Cmd "log-start" "Begin logging to the specified path" (TokenArg "path" NoArg) $ \ (path, ()) -> startLogging $ T.unpack path @@ -148,6 +162,12 @@ , Cmd "remove-user" "Remove a user from the current channel" (TokenArg "username" NoArg) $ \ (uname, ()) -> removeUserFromCurrentChannel uname + + , Cmd "user" "Show users to initiate a private DM chat channel" + -- n.b. this is identical to "msg", but is provided as an + -- alternative mental model for useability. + NoArg $ \ () -> + enterDMSearchUserList , Cmd "message-preview" "Toggle preview of the current message" NoArg $ \_ -> toggleMessagePreview diff --git a/src/Command.hs-boot b/src/Command.hs-boot new file mode 100644 --- /dev/null +++ b/src/Command.hs-boot @@ -0,0 +1,9 @@ +module Command where + +import Data.Text ( Text ) + +import Types ( MH, Cmd, CmdArgs ) + +commandList :: [Cmd] +printArgSpec :: CmdArgs a -> Text +dispatchCommand :: Text -> MH () diff --git a/src/Config.hs b/src/Config.hs --- a/src/Config.hs +++ b/src/Config.hs @@ -71,6 +71,8 @@ configPort <- fieldDefOf "port" number (configPort defaultConfig) configChannelListWidth <- fieldDefOf "channelListWidth" number (configChannelListWidth defaultConfig) + configCpuUsagePolicy <- fieldDefOf "cpuUsagePolicy" cpuUsagePolicy + (configCpuUsagePolicy defaultConfig) configLogMaxBufferSize <- fieldDefOf "logMaxBufferSize" number (configLogMaxBufferSize defaultConfig) configTimeFormat <- fieldMbOf "timeFormat" stringField @@ -105,6 +107,8 @@ pure Nothing configUnsafeUseHTTP <- fieldFlagDef "unsafeUseUnauthenticatedConnection" False + configDirectChannelExpirationDays <- fieldDefOf "directChannelExpirationDays" number + (configDirectChannelExpirationDays defaultConfig) let configAbsPath = Nothing configUserKeys = mempty @@ -129,6 +133,13 @@ _ -> Left ("Invalid value " <> show t <> "; must be one of: Disabled, Active, ActiveCount") +cpuUsagePolicy :: Text -> Either String CPUUsagePolicy +cpuUsagePolicy t = + case T.toLower t of + "single" -> return SingleCPU + "multiple" -> return MultipleCPUs + _ -> Left $ "Invalid CPU usage policy value: " <> show t + stringField :: Text -> Either String Text stringField t = case isQuoted t of @@ -151,34 +162,36 @@ defaultConfig :: Config defaultConfig = - Config { configAbsPath = Nothing - , configUser = Nothing - , configHost = Nothing - , configTeam = Nothing - , configPort = defaultPort - , configPass = Nothing - , configTimeFormat = Nothing - , configDateFormat = Nothing - , configTheme = Nothing - , configThemeCustomizationFile = Nothing - , configSmartBacktick = True - , configURLOpenCommand = Nothing - , configURLOpenCommandInteractive = False - , configActivityNotifyCommand = Nothing - , configActivityBell = False - , configShowBackground = Disabled - , configShowMessagePreview = False - , configShowChannelList = True - , configEnableAspell = False - , configAspellDictionary = Nothing - , configUnsafeUseHTTP = False - , configChannelListWidth = 20 - , configLogMaxBufferSize = 200 - , configShowOlderEdits = True - , configUserKeys = mempty - , configShowTypingIndicator = False - , configHyperlinkingMode = True - , configSyntaxDirs = [] + Config { configAbsPath = Nothing + , configUser = Nothing + , configHost = Nothing + , configTeam = Nothing + , configPort = defaultPort + , configPass = Nothing + , configTimeFormat = Nothing + , configDateFormat = Nothing + , configTheme = Nothing + , configThemeCustomizationFile = Nothing + , configSmartBacktick = True + , configURLOpenCommand = Nothing + , configURLOpenCommandInteractive = False + , configActivityNotifyCommand = Nothing + , configActivityBell = False + , configShowBackground = Disabled + , configShowMessagePreview = False + , configShowChannelList = True + , configEnableAspell = False + , configAspellDictionary = Nothing + , configUnsafeUseHTTP = False + , configChannelListWidth = 20 + , configLogMaxBufferSize = 200 + , configShowOlderEdits = True + , configUserKeys = mempty + , configShowTypingIndicator = False + , configHyperlinkingMode = True + , configSyntaxDirs = [] + , configDirectChannelExpirationDays = 7 + , configCpuUsagePolicy = MultipleCPUs } findConfig :: Maybe FilePath -> IO (Either String Config) diff --git a/src/Draw.hs b/src/Draw.hs --- a/src/Draw.hs +++ b/src/Draw.hs @@ -20,7 +20,6 @@ draw st = case appMode st of Main -> drawMain st - ChannelScroll -> drawMain st UrlSelect -> drawMain st ShowHelp topic -> drawShowHelp topic st ChannelSelect -> drawMain st diff --git a/src/Draw/Autocomplete.hs b/src/Draw/Autocomplete.hs --- a/src/Draw/Autocomplete.hs +++ b/src/Draw/Autocomplete.hs @@ -44,7 +44,8 @@ " match" <> if numResults == 1 then "" else "es" selElem = snd <$> listSelectedElement matchList - footer = case renderAutocompleteFooterFor =<< selElem of + curChan = st^.csCurrentChannel + footer = case renderAutocompleteFooterFor curChan =<< selElem of Just w -> hBorderWithLabel w _ -> hBorder @@ -53,7 +54,7 @@ else Widget Greedy Greedy $ do ctx <- getContext let rowOffset = ctx^.availHeightL - 3 - editorOffset - visibleHeight - editorOffset = if st^.csEditState.cedMultiline + editorOffset = if st^.csEditState.cedEphemeral.eesMultiline then multilineHeightLimit else 0 render $ translateBy (Location (0, rowOffset)) $ @@ -63,18 +64,22 @@ , footer ] -renderAutocompleteFooterFor :: AutocompleteAlternative -> Maybe (Widget Name) -renderAutocompleteFooterFor (UserCompletion _ False) = +renderAutocompleteFooterFor :: ClientChannel -> AutocompleteAlternative -> Maybe (Widget Name) +renderAutocompleteFooterFor ch (UserCompletion _ False) = Just $ hBox [ txt $ "(" , withDefAttr clientEmphAttr (txt userNotInChannelMarker) - , txt ": not in this channel)" + , txt ": not a member of " + , withDefAttr channelNameAttr (txt $ normalChannelSigil <> ch^.ccInfo.cdName) + , txt ")" ] -renderAutocompleteFooterFor (ChannelCompletion False _) = +renderAutocompleteFooterFor _ (ChannelCompletion False ch) = Just $ hBox [ txt $ "(" , withDefAttr clientEmphAttr (txt userNotInChannelMarker) - , txt ": not in this channel)" + , txt ": you are not a member of " + , withDefAttr channelNameAttr (txt $ normalChannelSigil <> sanitizeUserText (channelName ch)) + , txt ")" ] -renderAutocompleteFooterFor _ = Nothing +renderAutocompleteFooterFor _ _ = Nothing renderAutocompleteAlternative :: Bool -> AutocompleteAlternative -> Widget Name renderAutocompleteAlternative sel (UserCompletion u inChan) = diff --git a/src/Draw/ChannelList.hs b/src/Draw/ChannelList.hs --- a/src/Draw/ChannelList.hs +++ b/src/Draw/ChannelList.hs @@ -25,7 +25,7 @@ import Brick.Widgets.Border import Brick.Widgets.Center (hCenter) import qualified Data.Text as T -import Lens.Micro.Platform (at, non) +import Lens.Micro.Platform (non) import qualified Network.Mattermost.Types as MM @@ -117,10 +117,15 @@ else u^.uiName in (uname, Just $ T.singleton $ userSigilFromInfo u, True, Just $ u^.uiStatus) sigilWithSpace = sigil <> if addSpace then " " else "" - sigil = case st^.csEditState.cedLastChannelInput.at cId of - Nothing -> fromMaybe "" normalSigil - Just ("", _) -> fromMaybe "" normalSigil - _ -> "»" + prevEditSigil = "»" + sigil = if current + then fromMaybe "" normalSigil + else case chan^.ccEditState.eesInputHistoryPosition of + Just _ -> prevEditSigil + Nothing -> + case chan^.ccEditState.eesLastInput of + ("", _) -> fromMaybe "" normalSigil + _ -> prevEditSigil mentions = chan^.ccInfo.cdMentionCount -- | Render an individual Channel List entry (in Normal mode) with diff --git a/src/Draw/Main.hs b/src/Draw/Main.hs --- a/src/Draw/Main.hs +++ b/src/Draw/Main.hs @@ -49,12 +49,12 @@ -- If it starts with a slash but not /me, this has no preview -- representation let isCommand = "/" `T.isPrefixOf` s - isEmote = "/me " `T.isPrefixOf` s - content = if isEmote + isEmoteCmd = "/me " `T.isPrefixOf` s + content = if isEmoteCmd then T.stripStart $ T.drop 3 s else s - msgTy = fromMaybe (if isEmote then CP Emote else CP NormalPost) overrideTy - in if isCommand && not isEmote + msgTy = fromMaybe (if isEmoteCmd then CP Emote else CP NormalPost) overrideTy + in if isCommand && not isEmoteCmd then Nothing else Just $ Message { _mText = getBlocks content , _mMarkdownSource = content @@ -256,7 +256,7 @@ ] _ -> emptyWidget - commandBox = case st^.csEditState.cedMultiline of + commandBox = case st^.csEditState.cedEphemeral.eesMultiline of False -> let linesStr = "line" <> if numLines == 1 then "" else "s" numLines = length curContents @@ -325,17 +325,6 @@ body = chatText chatText = case appMode st of - ChannelScroll -> - -- n.b., In this mode, the output is cached and scrolled - -- via the viewport. This means that newly received - -- messages are *not* displayed, but this preserves the - -- stability of the scrolling, which provides a better - -- user experience. - viewport (ChannelMessages cId) Vertical $ - cached (ChannelMessages cId) $ - vBox $ (withDefAttr loadMoreAttr $ hCenter $ - str "<< Press C-b to load more messages >>") : - (toList $ renderSingleMessage st hs editCutoff <$> channelMessages) MessageSelect -> renderMessagesWithSelect (st^.csMessageSelect) channelMessages MessageSelectDeleteConfirm -> @@ -405,7 +394,7 @@ st ^?! csChannels.folding (findChannelById cId) . ccContents . cdMessages . to (filterMessages isShown) where isShown m | st^.csResources.crUserPreferences.userPrefShowJoinLeave = True - | otherwise = m^.mType /= CP Join && m^.mType /= CP Leave + | otherwise = not $ isJoinLeave m insertTransitions :: Messages -> Maybe NewMessageIndicator -> Text -> TimeZoneSeries -> Messages insertTransitions ms cutoff = insertDateMarkers $ foldr addMessage ms newMessagesT @@ -474,34 +463,48 @@ | KB { kbBindingInfo = Just e' , kbEvent = b } <- keymap - , e' == e ] - options = [ ( const True + , e' == e + ] + options = [ ( not . isGap , ev YankWholeMessageEvent - , "yank-all" ) + , "yank-all" + ) , ( \m -> isFlaggable m && not (m^.mFlagged) , ev FlagMessageEvent - , "flag" ) + , "flag" + ) , ( \m -> isFlaggable m && m^.mFlagged , ev FlagMessageEvent - , "unflag" ) + , "unflag" + ) , ( isReplyable , ev ReplyMessageEvent - , "reply" ) - , ( const True + , "reply" + ) + , ( not . isGap , ev ViewMessageEvent - , "view" ) + , "view" + ) + , ( isGap + , ev FillGapEvent + , "load messages" + ) , ( \m -> isMine st m && isEditable m , ev EditMessageEvent - , "edit" ) + , "edit" + ) , ( \m -> isMine st m && isDeletable m , ev DeleteMessageEvent - , "delete" ) + , "delete" + ) , ( const hasURLs , ev OpenMessageURLEvent - , openUrlsMsg ) + , openUrlsMsg + ) , ( const hasVerb , ev YankMessageEvent - , "yank-code" ) + , "yank-code" + ) ] Just postMsg = getSelectedMessage st @@ -574,10 +577,6 @@ , withDefAttr clientEmphAttr $ txt "Escape" , txt " to cancel." ] - ChannelScroll -> hCenter $ hBox [ txt "Press " - , withDefAttr clientEmphAttr $ txt "Escape" - , txt " to stop scrolling and resume chatting." - ] MessageSelectDeleteConfirm -> renderDeleteConfirm _ -> renderUserCommandBox st hs @@ -617,7 +616,10 @@ else hBox [ borderElem bsHorizontal , withDefAttr clientMessageAttr $ txt $ "(" <> (T.pack $ show count) <> " attachment" <> - (if count == 1 then "" else "s") <> ")" + (if count == 1 then "" else "s") <> "; " + , withDefAttr clientEmphAttr $ + txt $ ppBinding (getFirstDefaultBinding ShowAttachmentListEvent) + , txt " to manage)" ] showTypingUsers = case allTypingUsers (st^.csCurrentChannel.ccInfo.cdTypingUsers) of diff --git a/src/Draw/Messages.hs b/src/Draw/Messages.hs --- a/src/Draw/Messages.hs +++ b/src/Draw/Messages.hs @@ -77,22 +77,19 @@ in Just $ withDefAttr emojiAttr $ txt (" " <> reacMsg) msgTxt = case msg^.mUser of - NoUser -> + NoUser + | isGap msg -> withDefAttr gapMessageAttr m + | otherwise -> case msg^.mType of C DateTransition -> withDefAttr dateTransitionAttr (hBorderWithLabel m) C NewMessagesTransition -> withDefAttr newMessageTransitionAttr (hBorderWithLabel m) C Error -> withDefAttr errorMessageAttr m - C UnknownGap -> withDefAttr gapMessageAttr m _ -> withDefAttr clientMessageAttr m - _ | msg^.mType == CP Join || msg^.mType == CP Leave -> - withDefAttr clientMessageAttr m + _ | isJoinLeave msg -> withDefAttr clientMessageAttr m | otherwise -> m fullMsg = vBox $ msgTxt : catMaybes [msgAtch, msgReac] maybeRenderTime w = hBox [renderTimeFunc (msg^.mDate), txt " ", w] - maybeRenderTimeWith f = case msg^.mType of - C DateTransition -> id - C NewMessagesTransition -> id - _ -> f + maybeRenderTimeWith f = if isTransition msg then id else f in maybeRenderTimeWith maybeRenderTime fullMsg -- | Render a selected message with focus, including the messages diff --git a/src/Draw/ShowHelp.hs b/src/Draw/ShowHelp.hs --- a/src/Draw/ShowHelp.hs +++ b/src/Draw/ShowHelp.hs @@ -1,4 +1,9 @@ -module Draw.ShowHelp (drawShowHelp) where +module Draw.ShowHelp + ( drawShowHelp + , keybindingMarkdownTable + , keybindingTextTable + ) +where import Prelude () import Prelude.MH @@ -15,7 +20,6 @@ import Network.Mattermost.Version ( mmApiVersion ) import Command -import Events.ChannelScroll import Events.ChannelSelect import Events.Keybindings import Events.Main @@ -125,16 +129,38 @@ , [ "> *> /sh rot13 Hello, world!*\n" ] ] +keybindingMarkdownTable :: KeyConfig -> Text +keybindingMarkdownTable kc = keybindSectionStrings + where keybindSectionStrings = T.concat $ catMaybes $ sectionText <$> keybindSections kc + sectionText = mkKeybindEventSectionHelp keybindEventHelpMarkdown T.unlines mkHeading + mkHeading n = + "\n# " <> n <> + "\n| Keybinding | Description |" <> + "\n| ---------- | ----------- |" + +keybindingTextTable :: KeyConfig -> Text +keybindingTextTable kc = keybindSectionStrings + where keybindSectionStrings = T.concat $ catMaybes $ sectionText <$> keybindSections kc + sectionText = mkKeybindEventSectionHelp (keybindEventHelpText keybindingWidth) T.unlines mkHeading + keybindingWidth = 20 + mkHeading n = + "\n" <> n <> + "\n" <> (T.replicate (T.length n) "=") + keybindingHelp :: KeyConfig -> Widget Name -keybindingHelp kc = vBox $ +keybindingHelp kc = hCenter $ hLimit 100 $ vBox $ [ padTop (Pad 1) $ hCenter $ withDefAttr helpEmphAttr $ txt "Configurable Keybindings" - , padTop (Pad 1) $ hCenter $ hLimit 100 $ vBox keybindingHelpText - ] ++ map mkKeybindEventSectionHelp (keybindSections kc) + , padTop (Pad 1) $ hCenter $ vBox keybindingHelpText + ] ++ keybindSectionWidgets ++ [ padTop (Pad 1) $ hCenter $ withDefAttr helpEmphAttr $ txt "Keybinding Syntax" - , padTop (Pad 1) $ hCenter $ hLimit 100 $ vBox validKeys + , padTop (Pad 1) $ hCenter $ vBox validKeys ] - where keybindingHelpText = map (padTop (Pad 1) . renderText . mconcat) + where keybindSectionWidgets = catMaybes $ sectionWidget <$> keybindSections kc + sectionWidget = mkKeybindEventSectionHelp keybindEventHelpWidget vBox mkSectionHeading + mkSectionHeading = hCenter . padTop (Pad 1) . withDefAttr helpEmphAttr . txt + + keybindingHelpText = map (padTop (Pad 1) . renderText . mconcat) [ [ "Many of the keybindings used in Matterhorn can be " , "modified from within Matterhorn's **config.ini** file. " , "To do this, include a section called **[KEYBINDINGS]** " @@ -341,11 +367,10 @@ keybindSections :: KeyConfig -> [(Text, [Keybinding])] keybindSections kc = - [ ("This Help Page", helpKeybindings kc) + [ ("Help Page", helpKeybindings kc) , ("Main Interface", mainKeybindings kc) , ("Channel Select Mode", channelSelectKeybindings kc) , ("URL Select Mode", urlSelectKeybindings kc) - , ("Channel Scroll Mode", channelScrollKeybindings kc) , ("Message Select Mode", messageSelectKeybindings kc) , ("Text Editing", editingKeybindings) , ("Flagged Messages", postListOverlayKeybindings kc) @@ -377,25 +402,42 @@ (withDefAttr helpEmphAttr $ txt $ padTo kbColumnWidth $ ppBinding $ eventToBinding ev) <+> (vLimit 1 $ hLimit kbDescColumnWidth $ renderText desc <+> fill ' ') - -mkKeybindEventSectionHelp :: (Text, [Keybinding]) -> Widget Name -mkKeybindEventSectionHelp (sectionName, kbs) = +mkKeybindEventSectionHelp :: ((Text, Text, [Text]) -> a) + -> ([a] -> a) + -> (Text -> a) + -> (Text, [Keybinding]) + -> Maybe a +mkKeybindEventSectionHelp mkKeybindHelpFunc vertCat mkHeading (sectionName, kbs) = let lst = sortWith (fmap keyEventName . kbBindingInfo . head) $ groupWith kbBindingInfo kbs in if all (all (isNothing . kbBindingInfo)) lst - then emptyWidget - else (hCenter $ padTop (Pad 1) $ withDefAttr helpEmphAttr $ txt $ "Keybindings: " <> sectionName) <=> - (hCenter $ vBox $ concat $ mkKeybindEventHelp <$> lst) + then Nothing + else Just $ + vertCat $ (mkHeading $ "Keybindings: " <> sectionName) : + (mkKeybindHelpFunc <$> (catMaybes $ mkKeybindEventHelp <$> lst)) -mkKeybindEventHelp :: [Keybinding] -> [Widget Name] +keybindEventHelpWidget :: (Text, Text, [Text]) -> Widget Name +keybindEventHelpWidget (evName, desc, evs) = + let evText = T.intercalate ", " evs + in vBox [ txt (padTo 72 ("; " <> desc)) + , (withDefAttr helpEmphAttr $ txt evName) <+> txt (" = " <> evText) + , str " " + ] + +keybindEventHelpMarkdown :: (Text, Text, [Text]) -> Text +keybindEventHelpMarkdown (_evName, desc, evs) = + let quote s = "`" <> s <> "`" + in "| " <> (T.intercalate ", " $ quote <$> evs) <> " | " <> desc <> " |" + +keybindEventHelpText :: Int -> (Text, Text, [Text]) -> Text +keybindEventHelpText width (_evName, desc, evs) = + padTo width (T.intercalate ", " evs) <> " " <> desc + +mkKeybindEventHelp :: [Keybinding] -> Maybe (Text, Text, [Text]) mkKeybindEventHelp ks@(KB desc _ _ (Just e):_) = let evs = [ ev | KB _ ev _ _ <- ks ] - evText = T.intercalate ", " (map (ppBinding . eventToBinding) evs) - in [ txt (padTo 72 ("; " <> desc)) - , (withDefAttr helpEmphAttr $ txt $ keyEventName e) <+> - txt (" = " <> evText) - , str " " - ] -mkKeybindEventHelp _ = [] + evText = map (ppBinding . eventToBinding) evs + in Just (keyEventName e, desc, evText) +mkKeybindEventHelp _ = Nothing padTo :: Int -> Text -> Text padTo n s = s <> T.replicate (n - T.length s) " " diff --git a/src/Events.hs b/src/Events.hs --- a/src/Events.hs +++ b/src/Events.hs @@ -30,7 +30,6 @@ import Types import Types.Common -import Events.ChannelScroll import Events.ChannelSelect import Events.DeleteChannelConfirm import Events.JoinChannel @@ -160,7 +159,6 @@ UrlSelect -> onEventUrlSelect e LeaveChannelConfirm -> onEventLeaveChannelConfirm e JoinChannel -> onEventJoinChannel e - ChannelScroll -> onEventChannelScroll e MessageSelect -> onEventMessageSelect e MessageSelectDeleteConfirm -> onEventMessageSelectDeleteConfirm e DeleteChannelConfirm -> onEventDeleteChannelConfirm e diff --git a/src/Events/ChannelScroll.hs b/src/Events/ChannelScroll.hs deleted file mode 100644 --- a/src/Events/ChannelScroll.hs +++ /dev/null @@ -1,48 +0,0 @@ -module Events.ChannelScroll where - -import Prelude () -import Prelude.MH - -import Brick -import qualified Graphics.Vty as Vty - -import Events.Keybindings -import State.ChannelScroll -import State.UrlSelect -import Types - - -channelScrollKeybindings :: KeyConfig -> [Keybinding] -channelScrollKeybindings = mkKeybindings - [ mkKb LoadMoreEvent "Load more messages in the current channel" - loadMoreMessages - , mkKb EnterOpenURLModeEvent "Select and open a URL posted to the current channel" - startUrlSelect - , mkKb ScrollUpEvent "Scroll up" - channelScrollUp - , mkKb ScrollDownEvent "Scroll down" - channelScrollDown - , mkKb PageUpEvent "Scroll up" - channelPageUp - , mkKb PageDownEvent "Scroll down" - channelPageDown - , mkKb CancelEvent "Cancel scrolling and return to channel view" $ do - cId <- use csCurrentChannelId - mh $ invalidateCacheEntry (ChannelMessages cId) - setMode Main - , mkKb ScrollTopEvent "Scroll to top" - channelScrollToTop - , mkKb ScrollBottomEvent "Scroll to bottom" - channelScrollToBottom - ] - -onEventChannelScroll :: Vty.Event -> MH () -onEventChannelScroll = - handleKeyboardEvent channelScrollKeybindings $ \ e -> case e of - (Vty.EvResize _ _) -> do - cId <- use csCurrentChannelId - mh $ do - invalidateCache - let vp = ChannelMessages cId - vScrollToEnd $ viewportScroll vp - _ -> return () diff --git a/src/Events/Keybindings.hs b/src/Events/Keybindings.hs --- a/src/Events/Keybindings.hs +++ b/src/Events/Keybindings.hs @@ -139,6 +139,7 @@ SearchSelectDownEvent -> [ ctrl (key 'n'), kb Vty.KDown ] ViewMessageEvent -> [ key 'v' ] + FillGapEvent -> [ kb Vty.KEnter ] FlagMessageEvent -> [ key 'f' ] YankMessageEvent -> [ key 'y' ] YankWholeMessageEvent -> [ key 'Y' ] diff --git a/src/Events/Main.hs b/src/Events/Main.hs --- a/src/Events/Main.hs +++ b/src/Events/Main.hs @@ -4,31 +4,25 @@ import Prelude () import Prelude.MH -import Brick hiding ( Direction ) import Brick.Widgets.Edit import qualified Brick.Widgets.List as L import Data.Char ( isSpace ) -import qualified Data.Foldable as F -import qualified Data.Text as T import qualified Data.Text.Zipper as Z import qualified Data.Text.Zipper.Generic.Words as Z import qualified Graphics.Vty as Vty -import Lens.Micro.Platform ( (%=), (.=), to, at, _Just ) +import Lens.Micro.Platform ( (%=), to, _Just ) import Command -import Constants import Events.Keybindings import HelpTopics ( mainHelpTopic ) -import InputHistory import State.Attachments -import State.Help -import State.Channels import State.ChannelSelect +import State.Channels import State.Editing +import State.Help import State.MessageSelect import State.PostListOverlay ( enterFlaggedPostListMode ) import State.UrlSelect -import State.Messages ( sendMessage ) import Types @@ -86,7 +80,7 @@ "Scroll up in the channel input history" $ do -- Up in multiline mode does the usual thing; otherwise we -- navigate the history. - isMultiline <- use (csEditState.cedMultiline) + isMultiline <- use (csEditState.cedEphemeral.eesMultiline) case isMultiline of True -> mhHandleEventLensed (csEditState.cedEditor) handleEditorEvent (Vty.EvKey Vty.KUp []) @@ -97,20 +91,19 @@ "Scroll down in the channel input history" $ do -- Down in multiline mode does the usual thing; otherwise -- we navigate the history. - isMultiline <- use (csEditState.cedMultiline) + isMultiline <- use (csEditState.cedEphemeral.eesMultiline) case isMultiline of True -> mhHandleEventLensed (csEditState.cedEditor) handleEditorEvent (Vty.EvKey Vty.KDown []) False -> channelHistoryForward - , mkKb PageUpEvent "Page up in the channel message list" $ do - cId <- use csCurrentChannelId - let vp = ChannelMessages cId - mh $ invalidateCacheEntry vp - mh $ vScrollToEnd $ viewportScroll vp - mh $ vScrollBy (viewportScroll vp) (-1 * pageAmount) - setMode ChannelScroll + , mkKb PageUpEvent "Page up in the channel message list (enters message select mode)" $ do + beginMessageSelect + , mkKb ScrollTopEvent "Scroll to top of channel message list" $ do + beginMessageSelect + messageSelectFirst + , mkKb NextChannelEvent "Change to the next channel in the channel list" nextChannel @@ -132,13 +125,16 @@ , staticKb "Send the current message" (Vty.EvKey Vty.KEnter []) $ do - isMultiline <- use (csEditState.cedMultiline) + isMultiline <- use (csEditState.cedEphemeral.eesMultiline) case isMultiline of -- Normally, this event causes the current message to -- be sent. But in multiline mode we want to insert a -- newline instead. True -> handleEditingInput (Vty.EvKey Vty.KEnter []) - False -> handleInputSubmission + False -> do + cId <- use csCurrentChannelId + content <- getEditorContent + handleInputSubmission cId content , mkKb EnterOpenURLModeEvent "Select and open a URL posted to the current channel" startUrlSelect @@ -155,40 +151,6 @@ , mkKb EnterFlaggedPostsEvent "View currently flagged posts" enterFlaggedPostListMode ] - -handleInputSubmission :: MH () -handleInputSubmission = do - cmdLine <- use (csEditState.cedEditor) - cId <- use csCurrentChannelId - - -- send the relevant message - mode <- use (csEditState.cedEditMode) - let (line:rest) = getEditContents cmdLine - allLines = T.intercalate "\n" $ line : rest - - -- We clean up before dispatching the command or sending the message - -- since otherwise the command could change the state and then doing - -- cleanup afterwards could clean up the wrong things. - csEditState.cedEditor %= applyEdit Z.clearZipper - csEditState.cedInputHistory %= addHistoryEntry allLines cId - csEditState.cedInputHistoryPosition.at cId .= Nothing - - case T.uncons allLines of - Just ('/', cmd) -> - dispatchCommand cmd - _ -> do - attachments <- use (csEditState.cedAttachmentList.L.listElementsL) - sendMessage mode allLines $ F.toList attachments - - -- Reset the autocomplete UI - resetAutocomplete - - -- Empty the attachment list - resetAttachmentList - - -- Reset the edit mode *after* handling the input so that the input - -- handler can tell whether we're editing, replying, etc. - csEditState.cedEditMode .= NewPost data Direction = Forwards | Backwards diff --git a/src/Events/MessageSelect.hs b/src/Events/MessageSelect.hs --- a/src/Events/MessageSelect.hs +++ b/src/Events/MessageSelect.hs @@ -32,6 +32,10 @@ , mkKb SelectUpEvent "Select the previous message" messageSelectUp , mkKb SelectDownEvent "Select the next message" messageSelectDown + , mkKb ScrollTopEvent "Scroll to top and select the oldest message" + messageSelectFirst + , mkKb ScrollBottomEvent "Scroll to bottom and select the latest message" + messageSelectLast , mkKb PageUpEvent (T.pack $ "Move the cursor up by " <> show messagesPerPageOperation <> " messages") @@ -64,5 +68,8 @@ , mkKb ViewMessageEvent "View the selected message" viewSelectedMessage + + , mkKb FillGapEvent "Fetch messages for the selected gap" + fillSelectedGap ] diff --git a/src/Events/PostListOverlay.hs b/src/Events/PostListOverlay.hs --- a/src/Events/PostListOverlay.hs +++ b/src/Events/PostListOverlay.hs @@ -21,4 +21,5 @@ , mkKb SelectUpEvent "Select the previous message" postListSelectUp , mkKb SelectDownEvent "Select the next message" postListSelectDown , mkKb FlagMessageEvent "Toggle the selected message flag" postListUnflagSelected + , mkKb ActivateListItemEvent "Jump to and select current message" postListJumpToCurrent ] diff --git a/src/KeyMap.hs b/src/KeyMap.hs --- a/src/KeyMap.hs +++ b/src/KeyMap.hs @@ -7,7 +7,6 @@ import Prelude.MH import Events.Keybindings -import Events.ChannelScroll import Events.ChannelSelect import Events.Main import Events.MessageSelect @@ -22,7 +21,6 @@ , ("help screen", helpKeybindings) , ("channel select", channelSelectKeybindings) , ("url select", urlSelectKeybindings) - , ("channel scroll", channelScrollKeybindings) , ("message select", messageSelectKeybindings) , ("post list overlay", postListOverlayKeybindings) , ("attachment list", attachmentListKeybindings) diff --git a/src/Main.hs b/src/Main.hs --- a/src/Main.hs +++ b/src/Main.hs @@ -2,14 +2,16 @@ import Prelude () import Prelude.MH +import qualified Data.Text.IO as T -import System.Exit ( exitFailure ) +import System.Exit ( exitFailure, exitSuccess ) import Config import Options import App import Events.Keybindings ( ensureKeybindingConsistency ) import KeyMap ( keybindingModeMap ) +import Draw.ShowHelp ( keybindingMarkdownTable, keybindingTextTable ) main :: IO () @@ -26,7 +28,17 @@ exitFailure Right c -> return c - case ensureKeybindingConsistency (configUserKeys config) keybindingModeMap of + let keyConfig = configUserKeys config + + case optPrintKeybindings opts of + Nothing -> return () + Just ty -> do + case ty of + Markdown -> T.putStrLn $ keybindingMarkdownTable keyConfig + Plain -> T.putStrLn $ keybindingTextTable keyConfig + exitSuccess + + case ensureKeybindingConsistency keyConfig keybindingModeMap of Right () -> return () Left err -> do putStrLn $ "Configuration error: " <> err diff --git a/src/Markdown.hs b/src/Markdown.hs --- a/src/Markdown.hs +++ b/src/Markdown.hs @@ -1,3 +1,4 @@ +{-# LANGUAGE LambdaCase #-} {-# LANGUAGE MultiWayIf #-} {-# LANGUAGE ParallelListComp #-} {-# LANGUAGE RecordWildCards #-} @@ -47,22 +48,23 @@ import Network.Mattermost.Types ( ServerTime(..) ) import Themes -import Types ( HighlightSet(..), userSigil, normalChannelSigil - , isNameFragment, takeWhileNameFragment ) -import Types.Posts +import Types ( HighlightSet(..), userSigil, normalChannelSigil ) import Types.Messages +import Types.Posts +import Types.UserNames ( isNameFragment, takeWhileNameFragment ) emptyHSet :: HighlightSet emptyHSet = HighlightSet Set.empty Set.empty mempty -omitUsernameTypes :: [MessageType] -omitUsernameTypes = - [ CP Join - , CP Leave - , CP TopicChange - ] +omittedUsernameType :: MessageType -> Bool +omittedUsernameType = \case + CP Join -> True + CP Leave -> True + CP TopicChange -> True + _ -> False + -- The special string we use to indicate the placement of a styled -- indication that a message has been edited. editMarkingSentinel :: Text @@ -125,13 +127,11 @@ renderMessage :: MessageData -> Widget a renderMessage md@MessageData { mdMessage = msg, .. } = let msgUsr = case mdUserName of - Just u - | msg^.mType `elem` omitUsernameTypes -> Nothing - | otherwise -> Just u + Just u -> if omittedUsernameType (msg^.mType) then Nothing else Just u Nothing -> Nothing nameElems = case msgUsr of Just un - | msg^.mType == CP Emote -> + | isEmote msg -> [ B.txt "*", colorUsername un un , B.txt " " ] diff --git a/src/Options.hs b/src/Options.hs --- a/src/Options.hs +++ b/src/Options.hs @@ -20,19 +20,24 @@ | ShowHelp deriving (Eq, Show) +data KeybindingPrintMode = + Markdown | Plain deriving (Eq, Show) + data Options = Options - { optConfLocation :: Maybe FilePath - , optLogLocation :: Maybe FilePath - , optBehaviour :: Behaviour - , optIgnoreConfig :: Bool + { optConfLocation :: Maybe FilePath + , optLogLocation :: Maybe FilePath + , optBehaviour :: Behaviour + , optIgnoreConfig :: Bool + , optPrintKeybindings :: Maybe KeybindingPrintMode } deriving (Eq, Show) defaultOptions :: Options defaultOptions = Options - { optConfLocation = Nothing - , optLogLocation = Nothing - , optBehaviour = Normal - , optIgnoreConfig = False + { optConfLocation = Nothing + , optLogLocation = Nothing + , optBehaviour = Normal + , optIgnoreConfig = False + , optPrintKeybindings = Nothing } optDescrs :: [OptDescr (Options -> Options)] @@ -52,6 +57,12 @@ , Option ['i'] ["ignore-config"] (NoArg (\ c -> c { optIgnoreConfig = True })) "Start with no configuration" + , Option ['k'] ["keybindings-text"] + (NoArg (\ c -> c { optPrintKeybindings = Just Plain })) + "Print keybindings effective for the current configuration in plain text format" + , Option ['K'] ["keybindings-markdown"] + (NoArg (\ c -> c { optPrintKeybindings = Just Markdown })) + "Print keybindings effective for the current configuration in Markdown format" ] mhVersion :: String diff --git a/src/Prelude/MH.hs b/src/Prelude/MH.hs --- a/src/Prelude/MH.hs +++ b/src/Prelude/MH.hs @@ -6,9 +6,24 @@ putting changed functions behind CPP in a single place. -} +{- + GHC version <--> base version (https://wiki.haskell.org/Base_package) includes: + 8.0.1 4.9.0.0 + 8.2.1 4.10.0.0 + 8.4.1 4.11.0.0 + + GHC distributions include a set of core packages; overriding these + with new versions is unwise. Core packages include (see + https://downloads.haskell.org/~ghc/X.Y.Z/docs/html/users_guide/X.Y.Z-notes.html#included-libraries + ): + + base, Cabal, array, bytestring, containers, deepseq, directory, + filepath, mtl, parsec, process, text, time, unix +-} + module Prelude.MH ( module P -#if !MIN_VERSION_base(4,11,0) +#if !MIN_VERSION_base(4,9,0) , (<>) #endif , (<|>) @@ -48,6 +63,13 @@ , (Lens.^.) , Lens.use + -- not available in all versions of GHC currently in use +#if MIN_VERSION_base(4,10,0) + , Clock.nominalDay +#else + , nominalDay +#endif + -- various type aliases , Text , HashMap @@ -71,6 +93,9 @@ import qualified Data.List as List import qualified Data.Maybe as Maybe import qualified Data.Time as Time +#if MIN_VERSION_base(4,10,0) +import qualified Data.Time.Clock as Clock +#endif import qualified Data.Time.LocalTime.TimeZone.Series as Time import qualified GHC.Exts as Exts import qualified Lens.Micro.Platform as Lens @@ -83,3 +108,8 @@ import Data.Sequence ( Seq ) import Data.Set ( Set ) import Data.Text ( Text ) + +#if !MIN_VERSION_base(4,10,0) +nominalDay :: Time.NominalDiffTime +nominalDay = 86400 +#endif diff --git a/src/Scripts.hs b/src/Scripts.hs --- a/src/Scripts.hs +++ b/src/Scripts.hs @@ -46,7 +46,8 @@ case null $ programStderr po of True -> Just $ do mode <- use (csEditState.cedEditMode) - sendMessage mode (T.pack $ programStdout po) [] + cId <- use csCurrentChannelId + sendMessage cId mode (T.pack $ programStdout po) [] False -> Nothing ExitFailure _ -> Nothing diff --git a/src/State/Autocomplete.hs b/src/State/Autocomplete.hs --- a/src/State/Autocomplete.hs +++ b/src/State/Autocomplete.hs @@ -24,7 +24,7 @@ import Network.Mattermost.Types (userId, channelId) import qualified Network.Mattermost.Endpoints as MM -import Command ( commandList, printArgSpec ) +import {-# SOURCE #-} Command ( commandList, printArgSpec ) import State.Common import Types hiding ( newState ) diff --git a/src/State/ChannelScroll.hs b/src/State/ChannelScroll.hs deleted file mode 100644 --- a/src/State/ChannelScroll.hs +++ /dev/null @@ -1,54 +0,0 @@ -module State.ChannelScroll - ( - channelScrollToTop - , channelScrollToBottom - , channelScrollUp - , channelScrollDown - , channelPageUp - , channelPageDown - , loadMoreMessages - ) - where - -import Prelude () -import Prelude.MH - -import Brick.Main - -import Constants -import State.Messages -import Types - - -channelPageUp :: MH () -channelPageUp = do - cId <- use csCurrentChannelId - mh $ vScrollBy (viewportScroll (ChannelMessages cId)) (-1 * pageAmount) - -channelPageDown :: MH () -channelPageDown = do - cId <- use csCurrentChannelId - mh $ vScrollBy (viewportScroll (ChannelMessages cId)) pageAmount - -channelScrollUp :: MH () -channelScrollUp = do - cId <- use csCurrentChannelId - mh $ vScrollBy (viewportScroll (ChannelMessages cId)) (-1) - -channelScrollDown :: MH () -channelScrollDown = do - cId <- use csCurrentChannelId - mh $ vScrollBy (viewportScroll (ChannelMessages cId)) 1 - -channelScrollToTop :: MH () -channelScrollToTop = do - cId <- use csCurrentChannelId - mh $ vScrollToBeginning (viewportScroll (ChannelMessages cId)) - -channelScrollToBottom :: MH () -channelScrollToBottom = do - cId <- use csCurrentChannelId - mh $ vScrollToEnd (viewportScroll (ChannelMessages cId)) - -loadMoreMessages :: MH () -loadMoreMessages = whenMode ChannelScroll asyncFetchMoreMessages diff --git a/src/State/Channels.hs b/src/State/Channels.hs --- a/src/State/Channels.hs +++ b/src/State/Channels.hs @@ -22,7 +22,6 @@ , nextChannel , recentChannel , hideDMChannel - , hideCurrentDMChannel , createGroupChannel , showGroupChannelPref , channelHistoryForward @@ -103,7 +102,8 @@ us <- getUsers prefs <- use (csResources.crUserPreferences) now <- liftIO getCurrentTime - csFocus %= Z.updateList (mkChannelZipperList now cconfig prefs cs us) + config <- use (csResources.crConfiguration) + csFocus %= Z.updateList (mkChannelZipperList now config cconfig prefs cs us) -- Send the new zipper to the status update thread so that we can -- fetch the statuses for the users in the new sidebar. @@ -158,9 +158,12 @@ mh invalidateCache csShowChannelList %= not -hideCurrentDMChannel :: MH () -hideCurrentDMChannel = hideDMChannel =<< use csCurrentChannelId - +-- | If the current channel is a DM channel with a single user or a +-- group of users, hide it from the sidebar and adjust the server-side +-- preference to hide it persistently. +-- +-- If the current channel is any other kind of channel, complain with a +-- usage error. hideDMChannel :: ChannelId -> MH () hideDMChannel cId = do me <- gets myUser @@ -485,32 +488,32 @@ postChangeChannelCommon :: MH () postChangeChannelCommon = do - resetHistoryPosition resetEditorState updateChannelListScroll loadLastEdit - resetCurrentEdit fetchVisibleIfNeeded -resetCurrentEdit :: MH () -resetCurrentEdit = do - cId <- use csCurrentChannelId - csEditState.cedLastChannelInput.at cId .= Nothing - loadLastEdit :: MH () loadLastEdit = do cId <- use csCurrentChannelId - lastInput <- use (csEditState.cedLastChannelInput.at cId) - case lastInput of + + oldEphemeral <- preuse (csChannel(cId).ccEditState) + case oldEphemeral of Nothing -> return () - Just (lastEdit, lastEditMode) -> do - csEditState.cedEditor %= (applyEdit $ insertMany (lastEdit) . clearZipper) - csEditState.cedEditMode .= lastEditMode + Just e -> csEditState.cedEphemeral .= e -resetHistoryPosition :: MH () -resetHistoryPosition = do + loadLastChannelInput + +loadLastChannelInput :: MH () +loadLastChannelInput = do cId <- use csCurrentChannelId - csEditState.cedInputHistoryPosition.at cId .= Just Nothing + inputHistoryPos <- use (csEditState.cedEphemeral.eesInputHistoryPosition) + case inputHistoryPos of + Just i -> loadHistoryEntryToEditor cId i + Nothing -> do + (lastEdit, lastEditMode) <- use (csEditState.cedEphemeral.eesLastInput) + csEditState.cedEditor %= (applyEdit $ insertMany lastEdit . clearZipper) + csEditState.cedEditMode .= lastEditMode updateChannelListScroll :: MH () updateChannelListScroll = do @@ -532,12 +535,25 @@ saveCurrentEdit :: MH () saveCurrentEdit = do + saveCurrentChannelInput + + oldEphemeral <- use (csEditState.cedEphemeral) cId <- use csCurrentChannelId + csChannel(cId).ccEditState .= oldEphemeral + +saveCurrentChannelInput :: MH () +saveCurrentChannelInput = do cmdLine <- use (csEditState.cedEditor) mode <- use (csEditState.cedEditMode) - csEditState.cedLastChannelInput.at cId .= - Just (T.intercalate "\n" $ getEditContents $ cmdLine, mode) + -- Only save the editor contents if the user is not navigating the + -- history. + inputHistoryPos <- use (csEditState.cedEphemeral.eesInputHistoryPosition) + + when (isNothing inputHistoryPos) $ + csEditState.cedEphemeral.eesLastInput .= + (T.intercalate "\n" $ getEditContents $ cmdLine, mode) + hideGroupChannelPref :: ChannelId -> UserId -> Preference hideGroupChannelPref cId uId = Preference { preferenceCategory = PreferenceCategoryGroupChannelShow @@ -625,8 +641,6 @@ when (chan^.ccInfo.cdType /= Direct) $ do origFocus <- use csCurrentChannelId when (origFocus == cId) nextChannelSkipPrevView - csEditState.cedInputHistoryPosition .at cId .= Nothing - csEditState.cedLastChannelInput .at cId .= Nothing -- Update input history csEditState.cedInputHistory %= removeChannelHistory cId -- Update msgMap @@ -778,50 +792,39 @@ channelHistoryForward :: MH () channelHistoryForward = do cId <- use csCurrentChannelId - inputHistoryPos <- use (csEditState.cedInputHistoryPosition.at cId) - inputHistory <- use (csEditState.cedInputHistory) + inputHistoryPos <- use (csEditState.cedEphemeral.eesInputHistoryPosition) case inputHistoryPos of - Just (Just i) + Just i | i == 0 -> do -- Transition out of history navigation - csEditState.cedInputHistoryPosition.at cId .= Just Nothing - loadLastEdit + csEditState.cedEphemeral.eesInputHistoryPosition .= Nothing + loadLastChannelInput | otherwise -> do - let Just entry = getHistoryEntry cId newI inputHistory - newI = i - 1 - eLines = T.lines entry + let newI = i - 1 + loadHistoryEntryToEditor cId newI + csEditState.cedEphemeral.eesInputHistoryPosition .= (Just newI) + _ -> return () + +loadHistoryEntryToEditor :: ChannelId -> Int -> MH () +loadHistoryEntryToEditor cId idx = do + inputHistory <- use (csEditState.cedInputHistory) + case getHistoryEntry cId idx inputHistory of + Nothing -> return () + Just entry -> do + let eLines = T.lines entry mv = if length eLines == 1 then gotoEOL else id csEditState.cedEditor.editContentsL .= (mv $ textZipper eLines Nothing) - csEditState.cedInputHistoryPosition.at cId .= (Just $ Just newI) - _ -> return () channelHistoryBackward :: MH () channelHistoryBackward = do cId <- use csCurrentChannelId - inputHistoryPos <- use (csEditState.cedInputHistoryPosition.at cId) - inputHistory <- use (csEditState.cedInputHistory) - case inputHistoryPos of - Just (Just i) -> - let newI = i + 1 - in case getHistoryEntry cId newI inputHistory of - Nothing -> return () - Just entry -> do - let eLines = T.lines entry - mv = if length eLines == 1 then gotoEOL else id - csEditState.cedEditor.editContentsL .= (mv $ textZipper eLines Nothing) - csEditState.cedInputHistoryPosition.at cId .= (Just $ Just newI) - _ -> - let newI = 0 - in case getHistoryEntry cId newI inputHistory of - Nothing -> return () - Just entry -> - let eLines = T.lines entry - mv = if length eLines == 1 then gotoEOL else id - in do - saveCurrentEdit - csEditState.cedEditor.editContentsL .= (mv $ textZipper eLines Nothing) - csEditState.cedInputHistoryPosition.at cId .= (Just $ Just newI) + inputHistoryPos <- use (csEditState.cedEphemeral.eesInputHistoryPosition) + saveCurrentChannelInput + let newI = maybe 0 (+ 1) inputHistoryPos + loadHistoryEntryToEditor cId newI + csEditState.cedEphemeral.eesInputHistoryPosition .= (Just newI) + createOrdinaryChannel :: Text -> MH () createOrdinaryChannel name = do session <- getSession @@ -943,11 +946,15 @@ csPendingChannelChange .= (Just $ ChangeByChannelId chanId) doAsyncChannelMM Preempt chanId (\ s _ c -> MM.mmAddUser c member s) endAsyncNOP -createOrFocusDMChannel :: UserInfo -> MH () -createOrFocusDMChannel user = do +createOrFocusDMChannel :: UserInfo -> Maybe (ChannelId -> MH ()) -> MH () +createOrFocusDMChannel user successAct = do cs <- use csChannels case getDmChannelFor (user^.uiId) cs of - Just cId -> setFocus cId + Just cId -> do + setFocus cId + case successAct of + Nothing -> return () + Just act -> act cId Nothing -> do -- We have a user of that name but no channel. Time to make one! myId <- gets myUserId @@ -955,8 +962,8 @@ csPendingChannelChange .= (Just $ ChangeByUserId $ user^.uiId) doAsyncWith Normal $ do -- create a new channel - void $ MM.mmCreateDirectMessageChannel (user^.uiId, myId) session - return Nothing + chan <- MM.mmCreateDirectMessageChannel (user^.uiId, myId) session + return $ successAct <*> pure (channelId chan) -- | This switches to the named channel or creates it if it is a missing -- but valid user channel. @@ -972,7 +979,7 @@ case foundUser of -- We know about the user but there isn't already a DM -- channel, so create one. - Just user -> createOrFocusDMChannel user + Just user -> createOrFocusDMChannel user Nothing -- There were no matches of any kind. Nothing -> mhError $ NoSuchChannel name (Just cId, Nothing) diff --git a/src/State/Editing.hs b/src/State/Editing.hs --- a/src/State/Editing.hs +++ b/src/State/Editing.hs @@ -6,6 +6,8 @@ , toggleMultilineEditing , invokeExternalEditor , handlePaste + , handleInputSubmission + , getEditorContent , handleEditingInput , cancelAutocompleteOrReplyOrEdit , replyToLatestMessage @@ -18,10 +20,12 @@ import Brick.Main ( invalidateCache ) import Brick.Widgets.Edit ( Editor, applyEdit , handleEditorEvent , getEditContents, editContentsL ) +import qualified Brick.Widgets.List as L import qualified Codec.Binary.UTF8.Generic as UTF8 import Control.Arrow import qualified Control.Concurrent.STM as STM import qualified Data.ByteString as BS +import qualified Data.Foldable as F import qualified Data.Set as S import qualified Data.Text as T import qualified Data.Text.Encoding as T @@ -37,13 +41,16 @@ import qualified System.Process as Sys import Text.Aspell ( AspellResponse(..), mistakeWord, askAspell ) -import Network.Mattermost.Types ( Post(..) ) +import Network.Mattermost.Types ( Post(..), ChannelId ) import Config +import {-# SOURCE #-} Command ( dispatchCommand ) +import InputHistory import Events.Keybindings import State.Common import State.Autocomplete import State.Attachments +import State.Messages import Types hiding ( newState ) import Types.Common ( sanitizeChar, sanitizeUserText' ) @@ -51,13 +58,22 @@ startMultilineEditing :: MH () startMultilineEditing = do mh invalidateCache - csEditState.cedMultiline .= True + csEditState.cedEphemeral.eesMultiline .= True toggleMultilineEditing :: MH () toggleMultilineEditing = do mh invalidateCache - csEditState.cedMultiline %= not + csEditState.cedEphemeral.eesMultiline %= not + -- If multiline is now disabled and there is more than one line in + -- the editor, that means we're showing the multiline message status + -- (see Draw.Main.renderUserCommandBox.commandBox) so we want to be + -- sure no autocomplete UI is present in case the cursor was left on + -- a word that would otherwise show completion alternatives. + multiline <- use (csEditState.cedEphemeral.eesMultiline) + numLines <- use (csEditState.cedEditor.to getEditContents.to length) + when (not multiline && numLines > 1) resetAutocomplete + invokeExternalEditor :: MH () invokeExternalEditor = do -- If EDITOR is in the environment, write the current message to a @@ -103,7 +119,7 @@ editingPermitted :: ChatState -> Bool editingPermitted st = (length (getEditContents $ st^.csEditState.cedEditor) == 1) || - st^.csEditState.cedMultiline + st^.csEditState.cedEphemeral.eesMultiline editingKeybindings :: [Keybinding] editingKeybindings = @@ -168,6 +184,50 @@ (kbAction >> sendUserTypingAction) kbBindingInfo +getEditorContent :: MH Text +getEditorContent = do + cmdLine <- use (csEditState.cedEditor) + let (line:rest) = getEditContents cmdLine + return $ T.intercalate "\n" $ line : rest + +-- | Handle an input submission in the message editor. +-- +-- This handles the specified input text as if it were user input for +-- the specified channel. This means that if the specified input text +-- contains a command ("/...") then it is executed as normal. Otherwise +-- the text is sent as a message to the specified channel. +-- +-- However, this function assumes that the message editor is the +-- *source* of the text, so it also takes care of clearing the editor, +-- resetting the edit mode, updating the input history for the specified +-- channel, etc. +handleInputSubmission :: ChannelId -> Text -> MH () +handleInputSubmission cId content = do + -- We clean up before dispatching the command or sending the message + -- since otherwise the command could change the state and then doing + -- cleanup afterwards could clean up the wrong things. + csEditState.cedEditor %= applyEdit Z.clearZipper + csEditState.cedInputHistory %= addHistoryEntry content cId + csEditState.cedEphemeral.eesInputHistoryPosition .= Nothing + + case T.uncons content of + Just ('/', cmd) -> + dispatchCommand cmd + _ -> do + attachments <- use (csEditState.cedAttachmentList.L.listElementsL) + mode <- use (csEditState.cedEditMode) + sendMessage cId mode content $ F.toList attachments + + -- Reset the autocomplete UI + resetAutocomplete + + -- Empty the attachment list + resetAttachmentList + + -- Reset the edit mode *after* handling the input so that the input + -- handler can tell whether we're editing, replying, etc. + csEditState.cedEditMode .= NewPost + handleEditingInput :: Event -> MH () handleEditingInput e = do -- Only handle input events to the editor if we permit editing: @@ -180,6 +240,8 @@ smartBacktick <- use (csResources.crConfiguration.to configSmartBacktick) let smartChars = "*`_" st <- use id + csEditState.cedEphemeral.eesInputHistoryPosition .= Nothing + case lookupKeybinding e editingKeybindings of Just kb | editingPermitted st -> kbAction kb _ -> do @@ -208,13 +270,33 @@ let doInsertChar = do csEditState.cedEditor %= applyEdit (Z.insertChar ch) sendUserTypingAction - in if | (editorEmpty $ st^.csEditState.cedEditor) || + curLine = Z.currentLine $ st^.csEditState.cedEditor.editContentsL + -- First case: if the cursor is at the end of the current + -- line and it contains "``" and the user entered a third + -- "`", enable multi-line mode since they're likely typing + -- a code block. + in if | (cursorIsAtEnd $ st^.csEditState.cedEditor) && + curLine == "``" && + ch == '`' -> do + csEditState.cedEditor %= applyEdit (Z.insertMany (T.singleton ch)) + csEditState.cedEphemeral.eesMultiline .= True + -- Second case: user entered some smart character + -- (don't care which) on an empty line or at the end + -- of the line after whitespace, so enter a pair of + -- the smart chars and put the cursor between them. + | (editorEmpty $ st^.csEditState.cedEditor) || ((cursorAtChar ' ' (applyEdit Z.moveLeft $ st^.csEditState.cedEditor)) && (cursorIsAtEnd $ st^.csEditState.cedEditor)) -> csEditState.cedEditor %= applyEdit (Z.insertMany (T.pack $ ch:ch:[]) >>> Z.moveLeft) + -- Third case: the cursor is already on a smart + -- character and that character is the last one + -- on the line, so instead of inserting a new + -- character, just move past it. | (cursorAtChar ch $ st^.csEditState.cedEditor) && (cursorIsAtEnd $ applyEdit Z.moveRight $ st^.csEditState.cedEditor) -> csEditState.cedEditor %= applyEdit Z.moveRight + -- Fall-through case: just insert one of the chars + -- without doing anything smart. | otherwise -> doInsertChar | editingPermitted st -> do csEditState.cedEditor %= applyEdit (Z.insertMany (sanitizeChar ch)) diff --git a/src/State/MessageSelect.hs b/src/State/MessageSelect.hs --- a/src/State/MessageSelect.hs +++ b/src/State/MessageSelect.hs @@ -4,6 +4,7 @@ beginMessageSelect , flagSelectedMessage , viewSelectedMessage + , fillSelectedGap , yankSelectedMessageVerbatim , yankSelectedMessage , openSelectedMessageURLs @@ -12,6 +13,8 @@ , messageSelectUpBy , messageSelectDown , messageSelectDownBy + , messageSelectFirst + , messageSelectLast , deleteSelectedMessage , beginReplyCompose , beginEditMessage @@ -35,9 +38,10 @@ import Clipboard ( copyToClipboard ) import Markdown ( findVerbatimChunk ) +import State.Common +import State.Messages import Types import Types.Common -import State.Common getSelectedMessage :: ChatState -> Maybe Message @@ -79,9 +83,19 @@ viewSelectedMessage = do selected <- use (to getSelectedMessage) case selected of - Just msg -> viewMessage msg + Just msg + | not (isGap msg) -> viewMessage msg _ -> return () +fillSelectedGap :: MH () +fillSelectedGap = do + selected <- use (to getSelectedMessage) + case selected of + Just msg + | isGap msg -> do cId <- use csCurrentChannelId + asyncFetchMessagesForGap cId msg + _ -> return () + viewMessage :: Message -> MH () viewMessage m = do csViewedMessage .= Just m @@ -114,7 +128,11 @@ openSelectedMessageURLs :: MH () openSelectedMessageURLs = whenMode MessageSelect $ do - Just curMsg <- use (to getSelectedMessage) + mCurMsg <- use (to getSelectedMessage) + curMsg <- case mCurMsg of + Nothing -> error "BUG: openSelectedMessageURLs: no selected message available" + Just m -> return m + let urls = msgURLs curMsg when (not (null urls)) $ do openedAll <- and <$> mapM (openURL . OpenLinkChoice) urls @@ -165,6 +183,30 @@ | otherwise = messageSelectUp >> messageSelectUpBy (amt - 1) +messageSelectFirst :: MH () +messageSelectFirst = do + selected <- use (csMessageSelect.to selectMessageId) + case selected of + Just _ -> whenMode MessageSelect $ do + chanMsgs <- use (csCurrentChannel.ccContents.cdMessages) + case getEarliestSelectableMessage chanMsgs of + Just firstMsg -> + csMessageSelect .= MessageSelectState (firstMsg^.mMessageId <|> selected) + Nothing -> mhLog LogError "No first message found from current message?!" + _ -> return () + +messageSelectLast :: MH () +messageSelectLast = do + selected <- use (csMessageSelect.to selectMessageId) + case selected of + Just _ -> whenMode MessageSelect $ do + chanMsgs <- use (csCurrentChannel.ccContents.cdMessages) + case getLatestSelectableMessage chanMsgs of + Just lastSelMsg -> + csMessageSelect .= MessageSelectState (lastSelMsg^.mMessageId <|> selected) + Nothing -> mhLog LogError "No last message found from current message?!" + _ -> return () + deleteSelectedMessage :: MH () deleteSelectedMessage = do selectedMessage <- use (to getSelectedMessage) @@ -208,9 +250,10 @@ -- value of "emote" that we can look at. Note that the -- removed formatting needs to be reinstated just prior to -- issuing the API call to update the post. - let toEdit = if msg^.mType == CP Emote - then removeEmoteFormatting $ sanitizeUserText $ postMessage p - else sanitizeUserText $ postMessage p + let sanitized = sanitizeUserText $ postMessage p + let toEdit = if isEmote msg + then removeEmoteFormatting sanitized + else sanitized csEditState.cedEditor %= applyEdit (clearZipper >> (insertMany toEdit)) _ -> return () diff --git a/src/State/Messages.hs b/src/State/Messages.hs --- a/src/State/Messages.hs +++ b/src/State/Messages.hs @@ -7,7 +7,10 @@ , editMessage , deleteMessage , addNewPostedMessage + , addObtainedMessages , asyncFetchMoreMessages + , asyncFetchMessagesForGap + , asyncFetchMessagesSurrounding , fetchVisibleIfNeeded , disconnectChannels ) @@ -34,13 +37,14 @@ import Network.Mattermost.Types import Constants -import State.Common import State.Channels +import State.Common import State.Reactions import State.Users import TimeUtils import Types import Types.Common ( sanitizeUserText ) +import Types.DirectionalSeq ( DirectionalSeq, SeqDirection ) -- ---------------------------------------------------------------------- @@ -76,24 +80,25 @@ gapMsg = newGapMessage timeJustAfterLast timeJustAfterLast = maybe t0 (justAfter . _mDate) lastmsg_ t0 = ServerTime $ originTime -- use any time for a channel with no messages yet - newGapMessage = newMessageOfType (T.pack "Disconnected. Will refresh when connected.") (C UnknownGap) + newGapMessage = newMessageOfType + (T.pack "Disconnected. Will refresh when connected.") + (C UnknownGapAfter) in unless lastIsGap (csChannels %= modifyChannelById cId (ccContents.cdMessages %~ addMessage gapMsg)) lastMsg :: RetrogradeMessages -> Maybe Message lastMsg = withFirstMessage id -sendMessage :: EditMode -> Text -> [AttachmentData] -> MH () -sendMessage mode msg attachments = +-- | Send a message and attachments to the specified channel. +sendMessage :: ChannelId -> EditMode -> Text -> [AttachmentData] -> MH () +sendMessage chanId mode msg attachments = when (not $ shouldSkipMessage msg) $ do status <- use csConnectionStatus - st <- use id case status of Disconnected -> do let m = "Cannot send messages while disconnected." mhError $ GenericError m Connected -> do - let chanId = st^.csCurrentChannelId session <- getSession doAsync Preempt $ do -- Upload attachments @@ -116,9 +121,9 @@ } void $ MM.mmCreatePost pendingPost session Editing p ty -> do - let body = if ty == CP Emote - then addEmoteFormatting msg - else msg + let body = case ty of + CP Emote -> addEmoteFormatting msg + _ -> msg update = (postUpdateBody body) { postUpdateFileIds = if null fileIds then Nothing else Just fileIds @@ -161,8 +166,19 @@ addNewPostedMessage p = addMessageToState True True p >>= postProcessMessageAdd -addObtainedMessages :: ChannelId -> Int -> Posts -> MH PostProcessMessageAdd -addObtainedMessages cId reqCnt posts = do +-- | Adds the set of Posts to the indicated channel. The Posts must +-- all be for the specified Channel. The reqCnt argument indicates +-- how many posts were requested, which will determine whether a gap +-- message is added to either end of the posts list or not. +-- +-- The addTrailingGap is only True when fetching the very latest messages +-- for the channel, and will suppress the generation of a Gap message +-- following the added block of messages. +addObtainedMessages :: ChannelId -> Int -> Bool -> Posts -> MH PostProcessMessageAdd +addObtainedMessages cId reqCnt addTrailingGap posts = + if null $ posts^.postsOrderL + then return NoAction + else -- Adding a block of server-provided messages, which are known to -- be contiguous. Locally this may overlap with some UnknownGap -- messages, which can therefore be removed. Alternatively the @@ -178,6 +194,10 @@ localMessages = chan^.ccContents . cdMessages + -- Get a list of the duplicated message PostIds between + -- the messages already in the channel and the new posts + -- to be added. + match = snd $ removeMatchesFromSubset (\m -> maybe False (\p -> p `elem` pIdList) (messagePostId m)) (Just (MessagePostId earliestPId)) @@ -198,7 +218,19 @@ -- do not signal action needed for notifications), and -- remove any gaps in the overlapping region. - newGapMessage d = newMessageOfType "Additional messages???" (C UnknownGap) d + newGapMessage d isOlder = + -- newGapMessage is a helper for generating a gap + -- message + do uuid <- generateUUID + let txt = "Load " <> + (if isOlder then "older" else "newer") <> + " messages" <> + (if isOlder then " ↥↥↥" else " ↧↧↧") + ty = if isOlder + then C UnknownGapBefore + else C UnknownGapAfter + return (newMessageOfType txt ty d + & mMessageId .~ Just (MessageUUID uuid)) -- If this batch contains the latest known messages, do -- not add a following gap. A gap at this point is added @@ -210,17 +242,28 @@ -- location, so adding the gap here would cause an -- infinite update loop. - addingAtEnd = maybe True ((<=) latestDate) $ + addingAtEnd = maybe True (latestDate >=) $ (^.mDate) <$> getLatestPostMsg localMessages - addingAtStart = maybe True ((>=) earliestDate) $ + addingAtStart = maybe True (earliestDate <=) $ (^.mDate) <$> getEarliestPostMsg localMessages - removeStart = if addingAtStart && noMoreBefore then Nothing else Just (MessagePostId earliestPId) - removeEnd = if addingAtEnd then Nothing else Just (MessagePostId latestPId) + removeStart = if addingAtStart && noMoreBefore + then Nothing + else Just (MessagePostId earliestPId) + removeEnd = if addTrailingGap || (addingAtEnd && noMoreAfter) + then Nothing + else Just (MessagePostId latestPId) noMoreBefore = reqCnt < 0 && length pIdList < (-reqCnt) - noMoreAfter = reqCnt > 0 && length pIdList < reqCnt + noMoreAfter = addTrailingGap || reqCnt > 0 && length pIdList < reqCnt + reAddGapBefore = earliestPId `elem` dupPIds || noMoreBefore + -- addingAtEnd used to be in reAddGapAfter but does not + -- seem to be needed. I may have missed a specific use + -- case/scenario, so I've left it commented out here for + -- debug assistance. + reAddGapAfter = latestPId `elem` dupPIds || {- addingAtEnd || -} noMoreAfter + -- The post map returned by the server will *already* have -- all thread messages for each post that is part of a -- thread. By calling installMessagesFromPosts here, we go ahead @@ -248,28 +291,111 @@ , not (p `elem` dupPIds) ] - csChannels %= modifyChannelById cId - (ccContents.cdMessages %~ (fst . removeMatchesFromSubset isGap removeStart removeEnd)) + -- The channel messages now include all the fetched messages. + -- Things to do at this point are: + -- + -- 1. Remove any duplicates just added, as well as any gaps + -- 2. Add new gaps (if needed) at either end of the added + -- messages. + -- 3. Update the "current selection" if it was on a removed message. + -- + -- Do this with the updated copy of the channel's messages. - -- Add a gap at each end of the newly fetched data, unless: - -- 1. there is an overlap - -- 2. there is no more in the indicated direction - -- a. indicated by adding messages later than any currently - -- held messages (see note above re 'addingAtEnd'). - -- b. the amount returned was less than the amount requested + withChannelOrDefault cId () $ \updchan -> do + let updMsgs = updchan ^. ccContents . cdMessages - unless (earliestPId `elem` dupPIds || noMoreBefore) $ - let gapMsg = newGapMessage (justBefore earliestDate) - in csChannels %= modifyChannelById cId - (ccContents.cdMessages %~ addMessage gapMsg) + -- Remove any gaps in the added region. If there was an + -- active message selection and it is one of the removed + -- gaps, reset the selection to the beginning or end of the + -- added region (if there are any added selectable messages, + -- otherwise just the end if the message list in it's + -- entirety, or no selection at all). - unless (latestPId `elem` dupPIds || addingAtEnd || noMoreAfter) $ - let gapMsg = newGapMessage (justAfter latestDate) - in csChannels %= modifyChannelById cId - (ccContents.cdMessages %~ addMessage gapMsg) + let (resultMessages, removedMessages) = + removeMatchesFromSubset isGap removeStart removeEnd updMsgs + csChannels %= modifyChannelById cId + (ccContents.cdMessages .~ resultMessages) + -- Determine if the current selected message was one of the + -- removed messages. + + selMsgId <- use (csMessageSelect.to selectMessageId) + let rmvdSel = do + i <- selMsgId -- :: Maybe MessageId + findMessage i removedMessages + rmvdSelType = _mType <$> rmvdSel + + case rmvdSel of + Nothing -> return () + Just rm -> + if isGap rm + then return () -- handled during gap insertion below + else do + -- Replaced a selected message that wasn't a gap. + -- This is unlikely, but may occur if the previously + -- selected message was just deleted by another user + -- and is in the fetched region. The choices here are + -- to move the selection, or cancel the selection. + -- Both will be unpleasant surprises for the user, but + -- cancelling the selection is probably the better + -- choice than allowing the user to perform select + -- actions on a message that isn't the one they just + -- selected. + setMode Main + csMessageSelect .= MessageSelectState Nothing + + -- Add a gap at each end of the newly fetched data, unless: + -- 1. there is an overlap + -- 2. there is no more in the indicated direction + -- a. indicated by adding messages later than any currently + -- held messages (see note above re 'addingAtEnd'). + -- b. the amount returned was less than the amount requested + + if reAddGapBefore + then + -- No more gaps. If the selected gap was removed, move + -- select to first (earliest) message) + case rmvdSelType of + Just (C UnknownGapBefore) -> + csMessageSelect .= MessageSelectState (pure $ MessagePostId earliestPId) + _ -> return () + else do + -- add a gap at the start of the newly fetched block and + -- make that the active selection if this fetch removed + -- the previously selected gap in this direction. + gapMsg <- newGapMessage (justBefore earliestDate) True + csChannels %= modifyChannelById cId + (ccContents.cdMessages %~ addMessage gapMsg) + -- Move selection from old gap to new gap + case rmvdSelType of + Just (C UnknownGapBefore) -> do + csMessageSelect .= MessageSelectState (gapMsg^.mMessageId) + _ -> return () + + if reAddGapAfter + then + -- No more gaps. If the selected gap was removed, move + -- select to last (latest) message. + case rmvdSelType of + Just (C UnknownGapAfter) -> + csMessageSelect .= MessageSelectState (pure $ MessagePostId latestPId) + _ -> return () + else do + -- add a gap at the end of the newly fetched block and + -- make that the active selection if this fetch removed + -- the previously selected gap in this direction. + gapMsg <- newGapMessage (justAfter latestDate) False + csChannels %= modifyChannelById cId + (ccContents.cdMessages %~ addMessage gapMsg) + -- Move selection from old gap to new gap + case rmvdSelType of + Just (C UnknownGapAfter) -> + csMessageSelect .= MessageSelectState (gapMsg^.mMessageId) + _ -> return () + -- Now initiate fetches for use information for any -- as-yet-unknown users related to this new set of messages + let users = foldr (\post s -> maybe s (flip Set.insert s) (postUserId post)) Set.empty (posts^.postsPostsL) addUnknownUsers inputUserIds = do @@ -293,14 +419,24 @@ -- existing UnknownGap entries and should be called when those are -- irrelevant. -- --- The boolean argument indicates whether this function should schedule --- a fetch for any mentioned users in the message. This is provided --- so that callers can batch this operation if a large collection of --- messages is being added together, in which case we don't want this --- function to schedule a single request per message (worst case). If --- you're calling this as part of scrollback processing, you should pass --- False. Otherwise if you're adding only a single message, you should --- pass True. +-- The first boolean argument ('fetchMentionedUsers') indicates +-- whether this function should schedule a fetch for any mentioned +-- users in the message. This is provided so that callers can batch +-- this operation if a large collection of messages is being added +-- together, in which case we don't want this function to schedule a +-- single request per message (worst case). If you're calling this as +-- part of scrollback processing, you should pass False. Otherwise if +-- you're adding only a single message, you should pass True. +-- +-- The second boolean argument ('fetchAuthor') is similar to the first +-- boolean argument but it refers to the author of the message instead +-- of any user mentions within the message body. +-- +-- The third argument ('newPostData') indicates whether this message +-- is being added as part of a fetch of old messages (e.g. scrollback) +-- or if ti is a new message and affects things like whether +-- notifications are generated and if the "New Messages" marker gets +-- updated. addMessageToState :: Bool -> Bool -> PostToAdd -> MH PostProcessMessageAdd addMessageToState fetchMentionedUsers fetchAuthor newPostData = do let (new, wasMentioned) = case newPostData of @@ -376,7 +512,10 @@ (adjustUpdated new) . (\c -> if currCId == cId then c - else updateNewMessageIndicator new c) . + else case newPostData of + OldPost _ -> c + RecentPost _ _ -> + updateNewMessageIndicator new c) . (\c -> if wasMentioned then c & ccInfo.cdMentionCount %~ succ else c) @@ -512,37 +651,156 @@ -- received in this mode are not normally shown, but this explicit -- user-driven fetch should be displayed, so this also invalidates the -- cache. +-- +-- This function assumes it is being called to add "older" messages to +-- the message history (i.e. near the beginning of the known +-- messages). It will normally try to overlap the fetch with the +-- known existing messages so that when the fetch results are +-- processed (which should be a contiguous set of messages as provided +-- by the server) there will be an overlap with existing messages; if +-- there is no overlap, then a special "gap" must be inserted in the +-- area between the existing messages and the newly fetched messages +-- to indicate that this client does not know if there are missing +-- messages there or not. +-- +-- In order to achieve an overlap, this code attempts to get the +-- second oldest messages as the message ID to pass to the server as +-- the "older than" marker ('postQueryBefore'), so that the oldest +-- message here overlaps with the fetched results to ensure no gap +-- needs to be inserted. However, there may already be a gap between +-- the oldest and second-oldest messages, so this code must actually +-- search for the first set of two *contiguous* messages it is aware +-- of to avoid adding additional gaps. (It's OK if gaps are added, but +-- the user must explicitly request a check for messages in order to +-- eliminate them, so it's better to avoid adding them in the first +-- place). This code is nearly always used to extend the older +-- history of a channel that information has already been retrieved +-- from, so it's almost certain that there are at least two contiguous +-- messages to use as a starting point, but exceptions are new +-- channels and empty channels. asyncFetchMoreMessages :: MH () asyncFetchMoreMessages = do cId <- use csCurrentChannelId withChannel cId $ \chan -> let offset = max 0 $ length (chan^.ccContents.cdMessages) - 2 - -- Fetch more messages prior to any existing messages, but - -- attempt to overlap with existing messages for - -- determining contiguity or gaps. Back up two messages - -- and request from there backward, which should include - -- the last message in the response. This is an attempt - -- to fetch *more* messages, so it's expected that there - -- are at least 2 messages already here, but in case there - -- aren't, just get another page from roughly the right - -- location. - first' = splitMessagesOn (isJust . messagePostId) (chan^.ccContents.cdMessages) - second' = splitMessagesOn (isJust . messagePostId) $ snd $ snd first' + page = offset `div` pageAmount + usefulMsgs = getTwoContiguousPosts Nothing (chan^.ccContents.cdMessages.to reverseMessages) + sndOldestId = (messagePostId . snd) =<< usefulMsgs query = MM.defaultPostQuery - { MM.postQueryPage = Just (offset `div` pageAmount) + { MM.postQueryPage = maybe (Just page) (const Nothing) sndOldestId , MM.postQueryPerPage = Just pageAmount + , MM.postQueryBefore = sndOldestId } - & \q -> case (fst first', fst second' >>= messagePostId) of - (Just _, Just i) -> q { MM.postQueryBefore = Just i - , MM.postQueryPage = Just 0 - } - _ -> q + addTrailingGap = MM.postQueryBefore query == Nothing && + MM.postQueryPage query == Just 0 in doAsyncChannelMM Preempt cId (\s _ c -> MM.mmGetPostsForChannel c query s) (\c p -> Just $ do - addObtainedMessages c (-pageAmount) p >>= postProcessMessageAdd + pp <- addObtainedMessages c (-pageAmount) addTrailingGap p + postProcessMessageAdd pp mh $ invalidateCacheEntry (ChannelMessages cId)) + +-- | Given a starting point and a direction to move from that point, +-- returns the closest two adjacent messages on that direction (as a +-- tuple of closest and next-closest), or Nothing if there are no +-- adjacent messages in the indicated direction. +getTwoContiguousPosts :: SeqDirection dir => + Maybe Message + -> DirectionalSeq dir Message + -> Maybe (Message, Message) +getTwoContiguousPosts startMsg msgs = + let go start = + do anchor <- getRelMessageId (_mMessageId =<< start) msgs + hinge <- getRelMessageId (anchor^.mMessageId) msgs + if isGap anchor || isGap hinge + then go $ Just anchor + else Just (anchor, hinge) + in go startMsg + + +asyncFetchMessagesForGap :: ChannelId -> Message -> MH () +asyncFetchMessagesForGap cId gapMessage = + when (isGap gapMessage) $ + withChannel cId $ \chan -> + let offset = max 0 $ length (chan^.ccContents.cdMessages) - 2 + page = offset `div` pageAmount + chanMsgs = chan^.ccContents.cdMessages + fromMsg = Just gapMessage + fetchNewer = case gapMessage^.mType of + C UnknownGapAfter -> True + C UnknownGapBefore -> False + _ -> error "fetch gap messages: unknown gap message type" + baseId = messagePostId . snd =<< + case gapMessage^.mType of + C UnknownGapAfter -> getTwoContiguousPosts fromMsg $ + reverseMessages chanMsgs + C UnknownGapBefore -> getTwoContiguousPosts fromMsg chanMsgs + _ -> error "fetch gap messages: unknown gap message type" + query = MM.defaultPostQuery + { MM.postQueryPage = maybe (Just page) (const Nothing) baseId + , MM.postQueryPerPage = Just pageAmount + , MM.postQueryBefore = if fetchNewer then Nothing else baseId + , MM.postQueryAfter = if fetchNewer then baseId else Nothing + } + addTrailingGap = MM.postQueryBefore query == Nothing && + MM.postQueryPage query == Just 0 + in doAsyncChannelMM Preempt cId + (\s _ c -> MM.mmGetPostsForChannel c query s) + (\c p -> Just $ do + void $ addObtainedMessages c (-pageAmount) addTrailingGap p + mh $ invalidateCacheEntry (ChannelMessages cId)) + +-- | Given a particular message ID, this fetches n messages before and +-- after immediately before and after the specified message in order +-- to establish some context for that message. This is frequently +-- used as a background operation when looking at search or flag +-- results so that jumping to message select mode for one of those +-- messages will show a bit of context (and it also prevents showing +-- gap messages for adjacent targets). +-- +-- The result will be adding at most 2n messages to the channel, with +-- the input post ID being somewhere in the middle of the added +-- messages. +-- +-- Note that this fetch will add messages to the channel, but it +-- performs no notifications or updates of new-unread indicators +-- because it is assumed to be used for non-current (previously-seen) +-- messages in background mode. +asyncFetchMessagesSurrounding :: ChannelId -> PostId -> MH () +asyncFetchMessagesSurrounding cId pId = do + let query = MM.defaultPostQuery + { MM.postQueryBefore = Just pId + , MM.postQueryPerPage = Just reqAmt + } + reqAmt = 5 -- both before and after + doAsyncChannelMM Preempt cId + -- first get some messages before the target, no overlap + (\s _ c -> MM.mmGetPostsForChannel c query s) + (\c p -> Just $ do + let last2ndId = secondToLastPostId p + void $ addObtainedMessages c (-reqAmt) False p + mh $ invalidateCacheEntry (ChannelMessages cId) + -- now start 2nd from end of this fetch to fetch some + -- messages forward, also overlapping with this fetch and + -- the original message ID to eliminate all gaps in this + -- surrounding set of messages. + let query' = MM.defaultPostQuery + { MM.postQueryAfter = last2ndId + , MM.postQueryPerPage = Just $ reqAmt + 2 + } + doAsyncChannelMM Preempt cId + (\s' _ c' -> MM.mmGetPostsForChannel c' query' s') + (\c' p' -> Just $ do + void $ addObtainedMessages c' (reqAmt + 2) False p' + mh $ invalidateCacheEntry (ChannelMessages cId) + ) + ) + where secondToLastPostId posts = + let pl = toList $ postsOrder posts + in if length pl > 1 then Just $ last $ init pl else Nothing + + fetchVisibleIfNeeded :: MH () fetchVisibleIfNeeded = do sts <- use csConnectionStatus @@ -567,11 +825,13 @@ Just (MessagePostId pid) -> query { MM.postQueryBefore = Just pid } _ -> query op = \s _ c -> MM.mmGetPostsForChannel c finalQuery s + addTrailingGap = MM.postQueryBefore finalQuery == Nothing && + MM.postQueryPage finalQuery == Just 0 in when ((not $ chan^.ccContents.cdFetchPending) && gapInDisplayable) $ do csChannel(cId).ccContents.cdFetchPending .= True doAsyncChannelMM Preempt cId op (\c p -> Just $ do - addObtainedMessages c (-numToReq) p >>= postProcessMessageAdd + addObtainedMessages c (-numToReq) addTrailingGap p >>= postProcessMessageAdd csChannel(c).ccContents.cdFetchPending .= False) asyncFetchAttachments :: Post -> MH () diff --git a/src/State/PostListOverlay.hs b/src/State/PostListOverlay.hs --- a/src/State/PostListOverlay.hs +++ b/src/State/PostListOverlay.hs @@ -1,6 +1,7 @@ module State.PostListOverlay ( enterFlaggedPostListMode , enterSearchResultPostListMode + , postListJumpToCurrent , postListSelectUp , postListSelectDown , postListUnflagSelected @@ -8,16 +9,21 @@ ) where +import GHC.Exts ( IsList(..) ) import Prelude () import Prelude.MH +import qualified Data.Foldable as F import qualified Data.Text as T import Lens.Micro.Platform ( (.=) ) import Network.Mattermost.Endpoints import Network.Mattermost.Types +import State.Channels import State.Common import State.MessageSelect +import State.Messages ( addObtainedMessages + , asyncFetchMessagesSurrounding ) import Types import Types.DirectionalSeq (emptyDirSeq) @@ -27,8 +33,14 @@ enterPostListMode :: PostListContents -> Messages -> MH () enterPostListMode contents msgs = do csPostListOverlay.postListPosts .= msgs - csPostListOverlay.postListSelected .= (getLatestPostMsg msgs >>= messagePostId) + let mlatest = getLatestPostMsg msgs + pId = mlatest >>= messagePostId + cId = mlatest >>= \m -> m^.mChannelId + csPostListOverlay.postListSelected .= pId setMode $ PostListOverlay contents + case (pId, cId) of + (Just p, Just c) -> asyncFetchMessagesSurrounding c p + _ -> return () -- | Clear out the state of a PostListOverlay exitPostListMode :: MH () @@ -37,55 +49,78 @@ csPostListOverlay.postListSelected .= Nothing setMode Main --- | Create a PostListOverlay with flagged messages from the server. -enterFlaggedPostListMode :: MH () -enterFlaggedPostListMode = do + +createPostList :: PostListContents -> (Session -> IO Posts) -> MH () +createPostList contentsType fetchOp = do session <- getSession doAsyncWith Preempt $ do - posts <- mmGetListOfFlaggedPosts UserMe defaultFlaggedPostsQuery session + posts <- fetchOp session return $ Just $ do messages <- fst <$> installMessagesFromPosts posts - enterPostListMode PostListFlagged messages + -- n.b. do not use addNewPostedMessage because these messages + -- are not new, and so no notifications or channel highlighting + -- or other post-processing should be performed. + let plist = F.toList $ postsPosts posts + postsSpec p = Posts { postsPosts = fromList [(postId p, p)] + , postsOrder = fromList [postId p] + } + mapM_ (\p -> addObtainedMessages (postChannelId p) 0 False $ postsSpec p) plist + enterPostListMode contentsType messages + +-- | Create a PostListOverlay with flagged messages from the server. +enterFlaggedPostListMode :: MH () +enterFlaggedPostListMode = createPostList PostListFlagged $ + mmGetListOfFlaggedPosts UserMe defaultFlaggedPostsQuery + + -- | Create a PostListOverlay with post search result messages from the -- server. enterSearchResultPostListMode :: Text -> MH () -enterSearchResultPostListMode terms = do - session <- getSession - tId <- gets myTeamId - case T.null $ T.strip terms of - True -> postInfoMessage "Search command requires at least one search term." - False -> do - enterPostListMode (PostListSearch terms True) noMessages - doAsyncWith Preempt $ do - posts <- mmSearchForTeamPosts tId (SearchPosts terms False) session - return $ Just $ do - messages <- fst <$> installMessagesFromPosts posts - enterPostListMode (PostListSearch terms False) messages +enterSearchResultPostListMode terms + | T.null (T.strip terms) = postInfoMessage "Search command requires at least one search term." + | otherwise = do + enterPostListMode (PostListSearch terms True) noMessages + tId <- gets myTeamId + createPostList (PostListSearch terms False) $ + mmSearchForTeamPosts tId (SearchPosts terms False) + -- | Move the selection up in the PostListOverlay, which corresponds -- to finding a chronologically /newer/ message. postListSelectUp :: MH () postListSelectUp = do - msgId <- use (csPostListOverlay.postListSelected) + selId <- use (csPostListOverlay.postListSelected) posts <- use (csPostListOverlay.postListPosts) - let nextId = (getNextPostId msgId posts) - case nextId of + let nextMsg = getNextMessage (MessagePostId <$> selId) posts + case nextMsg of Nothing -> return () - Just _ -> - csPostListOverlay.postListSelected .= nextId + Just m -> do + let pId = m^.mMessageId >>= messageIdPostId + csPostListOverlay.postListSelected .= pId + case (m^.mChannelId, pId) of + (Just c, Just p) -> asyncFetchMessagesSurrounding c p + o -> mhLog LogError + (T.pack $ "postListSelectUp" <> + " unable to get channel or post ID: " <> show o) -- | Move the selection down in the PostListOverlay, which corresponds -- to finding a chronologically /old/ message. postListSelectDown :: MH () postListSelectDown = do - msgId <- use (csPostListOverlay.postListSelected) + selId <- use (csPostListOverlay.postListSelected) posts <- use (csPostListOverlay.postListPosts) - let prevId = (getPrevPostId msgId posts) - case prevId of + let prevMsg = getPrevMessage (MessagePostId <$> selId) posts + case prevMsg of Nothing -> return () - Just _ -> - csPostListOverlay.postListSelected .= prevId + Just m -> do + let pId = m^.mMessageId >>= messageIdPostId + csPostListOverlay.postListSelected .= pId + case (m^.mChannelId, pId) of + (Just c, Just p) -> asyncFetchMessagesSurrounding c p + o -> mhLog LogError + (T.pack $ "postListSelectDown" <> + " unable to get channel or post ID: " <> show o) -- | Unflag the post currently selected in the PostListOverlay, if any postListUnflagSelected :: MH () @@ -94,3 +129,25 @@ case msgId of Nothing -> return () Just pId -> flagMessage pId False + + +-- | Jumps to the specified message in the message's main channel +-- display and changes to MessageSelectState. +postListJumpToCurrent :: MH () +postListJumpToCurrent = do + msgId <- use (csPostListOverlay.postListSelected) + st <- use id + case msgId of + Nothing -> return () + Just pId -> + case getMessageForPostId st pId of + Just msg -> + case msg ^. mChannelId of + Just cId -> do + setFocus cId + setMode MessageSelect + csMessageSelect .= MessageSelectState (msg^.mMessageId) + Nothing -> + error "INTERNAL: selected Post ID not associated with a channel" + Nothing -> + error "INTERNAL: selected Post ID not added to global state!" diff --git a/src/State/Reactions.hs b/src/State/Reactions.hs --- a/src/State/Reactions.hs +++ b/src/State/Reactions.hs @@ -8,6 +8,7 @@ import Prelude () import Prelude.MH +import Brick.Main ( invalidateCacheEntry ) import qualified Data.Map.Strict as Map import Lens.Micro.Platform @@ -27,7 +28,9 @@ (\_ rs -> Just $ addReactions cId rs) addReactions :: ChannelId -> [Reaction] -> MH () -addReactions cId rs = csChannel(cId).ccContents.cdMessages %= fmap upd +addReactions cId rs = do + mh $ invalidateCacheEntry $ ChannelMessages cId + csChannel(cId).ccContents.cdMessages %= fmap upd where upd msg = msg & mReactions %~ insertAll (msg^.mMessageId) insert mId r | mId == Just (MessagePostId (r^.reactionPostIdL)) = Map.insertWith (+) (r^.reactionEmojiNameL) 1 @@ -35,7 +38,9 @@ insertAll mId msg = foldr (insert mId) msg rs removeReaction :: Reaction -> ChannelId -> MH () -removeReaction r cId = csChannel(cId).ccContents.cdMessages %= fmap upd +removeReaction r cId = do + mh $ invalidateCacheEntry $ ChannelMessages cId + csChannel(cId).ccContents.cdMessages %= fmap upd where upd m | m^.mMessageId == Just (MessagePostId $ r^.reactionPostIdL) = m & mReactions %~ (Map.insertWith (+) (r^.reactionEmojiNameL) (-1)) | otherwise = m diff --git a/src/State/Setup.hs b/src/State/Setup.hs --- a/src/State/Setup.hs +++ b/src/State/Setup.hs @@ -261,7 +261,7 @@ -- End thread startup ---------------------------------------------- now <- getCurrentTime - let chanIds = mkChannelZipperList now Nothing (cr^.crUserPreferences) clientChans noUsers + let chanIds = mkChannelZipperList now (cr^.crConfiguration) Nothing (cr^.crUserPreferences) clientChans noUsers chanZip = Z.fromList chanIds clientChans = foldr (uncurry addChannel) noChannels chanPairs startupState = diff --git a/src/State/UserListOverlay.hs b/src/State/UserListOverlay.hs --- a/src/State/UserListOverlay.hs +++ b/src/State/UserListOverlay.hs @@ -45,7 +45,7 @@ myTId <- gets myTeamId enterUserListMode (ChannelMembers cId myTId) (\u -> case u^.uiId /= myId of - True -> createOrFocusDMChannel u >> return True + True -> createOrFocusDMChannel u Nothing >> return True False -> return False ) @@ -75,7 +75,7 @@ _ -> Nothing enterUserListMode (AllUsers restrictTeam) (\u -> case u^.uiId /= myId of - True -> createOrFocusDMChannel u >> return True + True -> createOrFocusDMChannel u Nothing >> return True False -> return False ) diff --git a/src/Types.hs b/src/Types.hs --- a/src/Types.hs +++ b/src/Types.hs @@ -18,6 +18,7 @@ , StartupStateInfo(..) , MHError(..) , AttachmentData(..) + , CPUUsagePolicy(..) , OpenInBrowser(..) , ConnectionInfo(..) , SidebarUpdate(..) @@ -36,7 +37,6 @@ , HelpScreen(..) , PasswordSource(..) , MatchType(..) - , EditMode(..) , Mode(..) , ChannelSelectPattern(..) , PostListContents(..) @@ -93,11 +93,9 @@ , cedSpellChecker , cedMisspellings , cedEditMode + , cedEphemeral , cedEditor - , cedMultiline , cedInputHistory - , cedInputHistoryPosition - , cedLastChannelInput , cedAutocomplete , cedAutocompletePending @@ -191,10 +189,7 @@ , requestLogDestination , sendLogMessage - , isNameFragment - , requestQuit - , clientPostToMessage , getMessageForPostId , getParentMessage , resetSpellCheckTimer @@ -233,8 +228,6 @@ , ChannelSet , getHighlightSet - , takeWhileNameFragment - , module Types.Channels , module Types.Messages , module Types.Posts @@ -253,7 +246,6 @@ import Brick.Widgets.Edit ( Editor, editor ) import Brick.Widgets.List ( List, list ) import qualified Brick.Widgets.FileBrowser as FB -import qualified Cheapskate as C import Control.Concurrent ( ThreadId ) import Control.Concurrent.Async ( Async ) import qualified Control.Concurrent.STM as STM @@ -261,15 +253,13 @@ import qualified Control.Monad.State as St import qualified Control.Monad.Reader as R import qualified Data.ByteString as BS -import Data.Char ( isAlpha ) import qualified Data.Foldable as F import Data.Ord ( comparing ) import qualified Data.HashMap.Strict as HM -import Data.List ( sortBy, break ) -import qualified Data.Set as S +import Data.List ( sortBy ) import qualified Data.Sequence as Seq import qualified Data.Text as T -import Data.Time.Clock ( UTCTime, getCurrentTime, nominalDay, addUTCTime ) +import Data.Time.Clock ( UTCTime, getCurrentTime, addUTCTime ) import Data.UUID ( UUID ) import qualified Data.Vector as Vec import Lens.Micro.Platform ( at, makeLenses, lens, (%~), (^?!), (.=) @@ -391,8 +381,26 @@ -- ^ Whether to enable terminal hyperlinking mode. , configSyntaxDirs :: [FilePath] -- ^ The search path for syntax description XML files. + , configDirectChannelExpirationDays :: Int + -- ^ The number of days to show a user in the channel menu after a direct + -- message with them. + , configCpuUsagePolicy :: CPUUsagePolicy + -- ^ The CPU usage policy for the application. } deriving (Eq, Show) +-- | The policy for CPU usage. +-- +-- The idea is that Matterhorn can benefit from using multiple CPUs, +-- but the exact number is application-determined. We expose this policy +-- setting to the user in the configuration. +data CPUUsagePolicy = + SingleCPU + -- ^ Constrain the application to use one CPU. + | MultipleCPUs + -- ^ Permit the usage of multiple CPUs (the exact number is + -- determined by the application). + deriving (Eq, Show) + -- | The state of the UI diagnostic indicator for the async worker -- thread. data BackgroundInfo = @@ -425,14 +433,15 @@ (isJust $ _cdEditedMessageThreshold info) mkChannelZipperList :: UTCTime + -> Config -> Maybe ClientConfig -> UserPreferences -> ClientChannels -> Users -> [(ChannelListGroup, [ChannelListEntry])] -mkChannelZipperList now cconfig prefs cs us = +mkChannelZipperList now config cconfig prefs cs us = [ (ChannelGroupPublicChannels, getNonDMChannelIdsInOrder cs) - , (ChannelGroupDirectMessages, getDMChannelsInOrder now cconfig prefs us cs) + , (ChannelGroupDirectMessages, getDMChannelsInOrder now config cconfig prefs us cs) ] getNonDMChannelIdsInOrder :: ClientChannels -> [ChannelListEntry] @@ -443,14 +452,15 @@ filteredChannels matches cs getDMChannelsInOrder :: UTCTime + -> Config -> Maybe ClientConfig -> UserPreferences -> Users -> ClientChannels -> [ChannelListEntry] -getDMChannelsInOrder now cconfig prefs us cs = - let oneOnOneDmChans = getDMChannels now cconfig prefs us cs - groupChans = getGroupDMChannels now prefs cs +getDMChannelsInOrder now config cconfig prefs us cs = + let oneOnOneDmChans = getDMChannels now config cconfig prefs us cs + groupChans = getGroupDMChannels now config prefs cs allDmChans = groupChans <> oneOnOneDmChans sorter (u1, n1, _) (u2, n2, _) = if u1 == u2 @@ -479,22 +489,24 @@ u^.uiName getGroupDMChannels :: UTCTime + -> Config -> UserPreferences -> ClientChannels -> [(Bool, T.Text, ChannelListEntry)] -getGroupDMChannels now prefs cs = +getGroupDMChannels now config prefs cs = let matches (_, info) = info^.ccInfo.cdType == Group && - groupChannelShouldAppear now prefs info + groupChannelShouldAppear now config prefs info in fmap (\(cId, ch) -> (hasUnread' ch, ch^.ccInfo.cdName, CLGroupDM cId)) $ filteredChannels matches cs getDMChannels :: UTCTime + -> Config -> Maybe ClientConfig -> UserPreferences -> Users -> ClientChannels -> [(Bool, T.Text, ChannelListEntry)] -getDMChannels now cconfig prefs us cs = +getDMChannels now config cconfig prefs us cs = let mapping = allDmChannelMappings cs mappingWithUserInfo = catMaybes $ getInfo <$> mapping getInfo (uId, cId) = do @@ -503,7 +515,7 @@ case u^.uiDeleted of True -> Nothing False -> - if dmChannelShouldAppear now prefs c + if dmChannelShouldAppear now config prefs c then return (hasUnread' c, displayNameForUser u cconfig prefs, CLUserDM cId uId) else Nothing in mappingWithUserInfo @@ -515,10 +527,10 @@ -- -- Otherwise, only show it if at least one of the other conditions are -- met (see 'or' below). -dmChannelShouldAppear :: UTCTime -> UserPreferences -> ClientChannel -> Bool -dmChannelShouldAppear now prefs c = - let weeksAgo n = nominalDay * (-7 * n) - localCutoff = addUTCTime (weeksAgo 1) now +dmChannelShouldAppear :: UTCTime -> Config -> UserPreferences -> ClientChannel -> Bool +dmChannelShouldAppear now config prefs c = + let ndays = configDirectChannelExpirationDays config + localCutoff = addUTCTime (nominalDay * (-(fromIntegral ndays))) now cutoff = ServerTime localCutoff updated = c^.ccInfo.cdUpdated Just uId = c^.ccInfo.cdDMUserId @@ -531,10 +543,10 @@ updated >= cutoff ] -groupChannelShouldAppear :: UTCTime -> UserPreferences -> ClientChannel -> Bool -groupChannelShouldAppear now prefs c = - let weeksAgo n = nominalDay * (-7 * n) - localCutoff = addUTCTime (weeksAgo 1) now +groupChannelShouldAppear :: UTCTime -> Config -> UserPreferences -> ClientChannel -> Bool +groupChannelShouldAppear now config prefs c = + let ndays = configDirectChannelExpirationDays config + localCutoff = addUTCTime (nominalDay * (-(fromIntegral ndays))) now cutoff = ServerTime localCutoff updated = c^.ccInfo.cdUpdated in if hasUnread' c || maybe False (>= localCutoff) (c^.ccInfo.cdSidebarShowOverride) @@ -837,10 +849,14 @@ data ChatEditState = ChatEditState { _cedEditor :: Editor Text Name , _cedEditMode :: EditMode - , _cedMultiline :: Bool + , _cedEphemeral :: EphemeralEditState , _cedInputHistory :: InputHistory - , _cedInputHistoryPosition :: HashMap ChannelId (Maybe Int) - , _cedLastChannelInput :: HashMap ChannelId (Text, EditMode) + -- ^ The map of per-channel input history for the + -- application. We don't distribute the per-channel + -- history into the per-channel states (like we do + -- for other per-channel state) since keeping it + -- under the InputHistory banner lets us use a nicer + -- startup/shutdown disk file management API. , _cedYankBuffer :: Text , _cedSpellChecker :: Maybe (Aspell, IO ()) , _cedMisspellings :: Set Text @@ -869,28 +885,14 @@ } deriving (Eq, Show) --- | The input mode. -data EditMode = - NewPost - -- ^ The input is for a new post. - | Editing Post MessageType - -- ^ The input is to be used as a new body for an existing post of - -- the specified type. - | Replying Message Post - -- ^ The input is to be used as a new post in reply to the specified - -- post. - deriving (Show) - -- | We can initialize a new 'ChatEditState' value with just an edit -- history, which we save locally. emptyEditState :: InputHistory -> Maybe (Aspell, IO ()) -> IO ChatEditState emptyEditState hist sp = do browser <- FB.newFileBrowser FB.selectNonDirectories AttachmentFileBrowser Nothing return ChatEditState { _cedEditor = editor MessageInput Nothing "" - , _cedMultiline = False + , _cedEphemeral = defaultEphemeralEditState , _cedInputHistory = hist - , _cedInputHistoryPosition = mempty - , _cedLastChannelInput = mempty , _cedEditMode = NewPost , _cedYankBuffer = "" , _cedSpellChecker = sp @@ -939,7 +941,6 @@ | LeaveChannelConfirm | DeleteChannelConfirm | JoinChannel - | ChannelScroll | MessageSelect | MessageSelectDeleteConfirm | PostListOverlay PostListContents @@ -1463,92 +1464,12 @@ | SidebarUpdateDeferred deriving (Eq, Show) -isValidNameChar :: Char -> Bool -isValidNameChar c = isAlpha c || c == '_' || c == '.' || c == '-' -isNameFragment :: C.Inline -> Bool -isNameFragment (C.Str t) = - not (T.null t) && isValidNameChar (T.head t) -isNameFragment _ = False - --- | Builds a message from a ClientPost and also returns the set of --- usernames mentioned in the text of the message. -clientPostToMessage :: ClientPost -> (Message, S.Set Text) -clientPostToMessage cp = (m, usernames) - where - usernames = findUsernames $ cp^.cpText - m = Message { _mText = cp^.cpText - , _mMarkdownSource = cp^.cpMarkdownSource - , _mUser = - case cp^.cpUserOverride of - Just n | cp^.cpType == NormalPost -> UserOverride (n <> "[BOT]") - _ -> maybe NoUser UserI $ cp^.cpUser - , _mDate = cp^.cpDate - , _mType = CP $ cp^.cpType - , _mPending = cp^.cpPending - , _mDeleted = cp^.cpDeleted - , _mAttachments = cp^.cpAttachments - , _mInReplyToMsg = - case cp^.cpInReplyToPost of - Nothing -> NotAReply - Just pId -> InReplyTo pId - , _mMessageId = Just $ MessagePostId $ cp^.cpPostId - , _mReactions = cp^.cpReactions - , _mOriginalPost = Just $ cp^.cpOriginalPost - , _mFlagged = False - , _mChannelId = Just $ cp^.cpChannelId - } - resetAutocomplete :: MH () resetAutocomplete = do csEditState.cedAutocomplete .= Nothing csEditState.cedAutocompletePending .= Nothing -findUsernames :: C.Blocks -> S.Set Text -findUsernames = S.unions . F.toList . fmap blockFindUsernames - -blockFindUsernames :: C.Block -> S.Set Text -blockFindUsernames (C.Para is) = - inlineFindUsernames $ F.toList is -blockFindUsernames (C.Header _ is) = - inlineFindUsernames $ F.toList is -blockFindUsernames (C.Blockquote bs) = - findUsernames bs -blockFindUsernames (C.List _ _ bs) = - S.unions $ F.toList $ findUsernames <$> bs -blockFindUsernames _ = - mempty - -inlineFindUsernames :: [C.Inline] -> S.Set Text -inlineFindUsernames [] = mempty -inlineFindUsernames (C.Str "@" : rest) = - let (strs, remaining) = takeWhileNameFragment rest - in if null strs - then inlineFindUsernames remaining - else S.insert (T.concat $ getInlineStr <$> strs) $ inlineFindUsernames remaining -inlineFindUsernames (_ : rest) = - inlineFindUsernames rest - -getInlineStr :: C.Inline -> T.Text -getInlineStr (C.Str s) = s -getInlineStr _ = "" - -takeWhileNameFragment :: [C.Inline] -> ([C.Inline], [C.Inline]) -takeWhileNameFragment [] = ([], []) -takeWhileNameFragment rest = - let (strs, remaining) = break (not . isNameFragment) rest - -- Does the last element in strs start with a letter? If - -- not, move it to the remaining list. This avoids pulling - -- punctuation-only tokens into usernames, e.g. "Hello, - -- @foobar." - (strs', remaining') = - if length strs <= 1 - then (strs, remaining) - else let (initStrs, [lastStr]) = splitAt (length strs - 1) strs - in if isAlpha $ T.head $ getInlineStr lastStr - then (strs, remaining) - else (initStrs, lastStr : remaining) - in (strs', remaining') -- * Slash Commands diff --git a/src/Types/Channels.hs b/src/Types/Channels.hs --- a/src/Types/Channels.hs +++ b/src/Types/Channels.hs @@ -10,8 +10,12 @@ , ChannelInfo(..) , ClientChannels -- constructor remains internal , NewMessageIndicator(..) + , EphemeralEditState(..) + , EditMode(..) + , eesMultiline, eesInputHistoryPosition, eesLastInput + , defaultEphemeralEditState -- * Lenses created for accessing ClientChannel fields - , ccContents, ccInfo + , ccContents, ccInfo, ccEditState -- * Lenses created for accessing ChannelInfo fields , cdViewed, cdNewMessageIndicator, cdEditedMessageThreshold, cdUpdated , cdName, cdHeader, cdPurpose, cdType @@ -53,6 +57,7 @@ import qualified Data.HashMap.Strict as HM import qualified Data.Set as S +import qualified Data.Text as T import Lens.Micro.Platform ( (%~), (.~), Traversal', Lens' , makeLenses, ix, at , to, non ) @@ -71,8 +76,8 @@ ) import Types.Messages ( Messages, noMessages, addMessage - , clientMessageToMessage ) -import Types.Posts ( ClientMessageType(UnknownGap) + , clientMessageToMessage, Message, MessageType ) +import Types.Posts ( ClientMessageType(UnknownGapBefore) , newClientMessage, postIsLeave, postIsJoin ) import Types.Users ( TypingUsers, noTypingUsers, addTypingUser ) import Types.Common @@ -85,10 +90,36 @@ data ClientChannel = ClientChannel { _ccContents :: ChannelContents -- ^ A list of 'Message's in the channel - , _ccInfo :: ChannelInfo + , _ccInfo :: ChannelInfo -- ^ The 'ChannelInfo' for the channel + , _ccEditState :: EphemeralEditState + -- ^ Editor state that we swap in and out as the current channel is + -- changed. } +-- | The input state associated with the message editor. +data EditMode = + NewPost + -- ^ The input is for a new post. + | Editing Post MessageType + -- ^ The input is ultimately to replace the body of an existing post + -- of the specified type. + | Replying Message Post + -- ^ The input is to be used as a new post in reply to the specified + -- post. + deriving (Show) + +data EphemeralEditState = + EphemeralEditState { _eesMultiline :: Bool + -- ^ Whether the editor is in multiline mode + , _eesInputHistoryPosition :: Maybe Int + -- ^ The input history position, if any + , _eesLastInput :: (T.Text, EditMode) + -- ^ The input entered into the text editor last + -- time the user was focused on the channel + -- associated with this state. + } + -- Get a channel's name, depending on its type preferredChannelName :: Channel -> Text preferredChannelName ch @@ -148,13 +179,13 @@ } -- | An initial empty 'ChannelContents' value. This also contains an --- UnknownGap, which is a signal that causes actual content fetching. +-- UnknownGapBefore, which is a signal that causes actual content fetching. -- The initial Gap's timestamp is the local client time, but -- subsequent fetches will synchronize with the server (and eventually -- eliminate this Gap as well). emptyChannelContents :: MonadIO m => m ChannelContents emptyChannelContents = do - gapMsg <- clientMessageToMessage <$> newClientMessage UnknownGap "--Fetching messages--" + gapMsg <- clientMessageToMessage <$> newClientMessage UnknownGapBefore "--Fetching messages--" return $ ChannelContents { _cdMessages = addMessage gapMsg noMessages , _cdFetchPending = False } @@ -203,6 +234,7 @@ makeLenses ''ChannelContents makeLenses ''ChannelInfo makeLenses ''ClientChannel +makeLenses ''EphemeralEditState notifyPreference :: User -> ClientChannel -> NotifyOption notifyPreference u cc = @@ -217,7 +249,15 @@ return ClientChannel { _ccContents = contents , _ccInfo = initialChannelInfo myId nc + , _ccEditState = defaultEphemeralEditState } + +defaultEphemeralEditState :: EphemeralEditState +defaultEphemeralEditState = + EphemeralEditState { _eesMultiline = False + , _eesInputHistoryPosition = Nothing + , _eesLastInput = ("", NewPost) + } canLeaveChannel :: ChannelInfo -> Bool canLeaveChannel cInfo = not $ cInfo^.cdType `elem` [Direct] diff --git a/src/Types/DirectionalSeq.hs b/src/Types/DirectionalSeq.hs --- a/src/Types/DirectionalSeq.hs +++ b/src/Types/DirectionalSeq.hs @@ -1,6 +1,7 @@ -{-# LANGUAGE DeriveFunctor #-} {-# LANGUAGE DeriveFoldable #-} +{-# LANGUAGE DeriveFunctor #-} {-# LANGUAGE DeriveTraversable #-} +{-# LANGUAGE TypeFamilies #-} {- | These declarations allow the use of a DirectionalSeq, which is a Seq that uses a phantom type to identify the ordering of the @@ -19,9 +20,12 @@ data Chronological data Retrograde -class SeqDirection a +class SeqDirection a where + type ReverseDirection a instance SeqDirection Chronological + where type ReverseDirection Chronological = Retrograde instance SeqDirection Retrograde + where type ReverseDirection Retrograde = Chronological data SeqDirection dir => DirectionalSeq dir a = DSeq { dseq :: Seq a } diff --git a/src/Types/KeyEvents.hs b/src/Types/KeyEvents.hs --- a/src/Types/KeyEvents.hs +++ b/src/Types/KeyEvents.hs @@ -81,6 +81,7 @@ | ActivateListItemEvent | ViewMessageEvent + | FillGapEvent | FlagMessageEvent | YankMessageEvent | YankWholeMessageEvent @@ -141,6 +142,7 @@ , FlagMessageEvent , ViewMessageEvent + , FillGapEvent , YankMessageEvent , YankWholeMessageEvent , DeleteMessageEvent @@ -331,6 +333,7 @@ FlagMessageEvent -> "flag-message" ViewMessageEvent -> "view-message" + FillGapEvent -> "fetch-for-gap" YankMessageEvent -> "yank-message" YankWholeMessageEvent -> "yank-whole-message" DeleteMessageEvent -> "delete-message" diff --git a/src/Types/Messages.hs b/src/Types/Messages.hs --- a/src/Types/Messages.hs +++ b/src/Types/Messages.hs @@ -1,8 +1,8 @@ -{-# LANGUAGE MultiParamTypeClasses #-} +{-# LANGUAGE DeriveAnyClass #-} +{-# LANGUAGE DeriveGeneric #-} {-# LANGUAGE FlexibleInstances #-} +{-# LANGUAGE MultiParamTypeClasses #-} {-# LANGUAGE TemplateHaskell #-} -{-# LANGUAGE DeriveGeneric #-} -{-# LANGUAGE DeriveAnyClass #-} {-| @@ -41,6 +41,7 @@ ( -- * Message and operations on a single Message Message(..) , isDeletable, isReplyable, isEditable, isReplyTo, isGap, isFlaggable + , isEmote, isJoinLeave, isTransition , mText, mUser, mDate, mType, mPending, mDeleted , mAttachments, mInReplyToMsg, mMessageId, mReactions, mFlagged , mOriginalPost, mChannelId, mMarkdownSource @@ -52,6 +53,7 @@ , UserRef(..) , ReplyState(..) , clientMessageToMessage + , clientPostToMessage , newMessageOfType -- * Message Collections , Messages @@ -67,12 +69,16 @@ , splitMessagesOn , splitRetrogradeMessagesOn , findMessage + , getRelMessageId + , getNextMessage + , getPrevMessage , getNextMessageId , getPrevMessageId , getNextPostId , getPrevPostId , getEarliestPostMsg , getLatestPostMsg + , getEarliestSelectableMessage , getLatestSelectableMessage , findLatestUserMessage -- * Operations on any Message type @@ -96,10 +102,12 @@ import Cheapskate ( Blocks ) import qualified Cheapskate as C +import Control.Monad import qualified Data.Foldable as F import Data.Hashable ( Hashable ) import qualified Data.Map.Strict as Map import Data.Sequence as Seq +import qualified Data.Set as S import Data.Tuple import Data.UUID ( UUID ) import GHC.Generics ( Generic ) @@ -110,6 +118,7 @@ import Types.DirectionalSeq import Types.Posts +import Types.UserNames -- ---------------------------------------------------------------------- @@ -154,7 +163,10 @@ isDeletable :: Message -> Bool isDeletable m = isJust (messagePostId m) && - _mType m `elem` [CP NormalPost, CP Emote] + case _mType m of + CP NormalPost -> True + CP Emote -> True + _ -> False isFlaggable :: Message -> Bool isFlaggable = isJust . messagePostId @@ -162,12 +174,18 @@ isReplyable :: Message -> Bool isReplyable m = isJust (messagePostId m) && - (_mType m `elem` [CP NormalPost, CP Emote]) + case _mType m of + CP NormalPost -> True + CP Emote -> True + _ -> False isEditable :: Message -> Bool isEditable m = isJust (messagePostId m) && - _mType m `elem` [CP NormalPost, CP Emote] + case _mType m of + CP NormalPost -> True + CP Emote -> True + _ -> False isReplyTo :: PostId -> Message -> Bool isReplyTo expectedParentId m = @@ -176,15 +194,35 @@ InReplyTo actualParentId -> actualParentId == expectedParentId isGap :: Message -> Bool -isGap m = _mType m == C UnknownGap +isGap m = case _mType m of + C UnknownGapBefore -> True + C UnknownGapAfter -> True + _ -> False +isTransition :: Message -> Bool +isTransition m = case _mType m of + C DateTransition -> True + C NewMessagesTransition -> True + _ -> False + +isEmote :: Message -> Bool +isEmote m = case _mType m of + CP Emote -> True + _ -> False + +isJoinLeave :: Message -> Bool +isJoinLeave m = case _mType m of + CP Join -> True + CP Leave -> True + _ -> False + -- | A 'Message' is the representation we use for storage and -- rendering, so it must be able to represent either a -- post from Mattermost or an internal message. This represents -- the union of both kinds of post types. data MessageType = C ClientMessageType | CP ClientPostType - deriving (Eq, Show) + deriving (Show) -- | There may be no user (usually an internal message), a reference -- to a user (by Id), or the server may have supplied a specific @@ -232,6 +270,36 @@ , _mChannelId = Nothing } + +-- | Builds a message from a ClientPost and also returns the set of +-- usernames mentioned in the text of the message. +clientPostToMessage :: ClientPost -> (Message, S.Set Text) +clientPostToMessage cp = (m, usernames) + where + usernames = findUsernames $ cp^.cpText + m = Message { _mText = cp^.cpText + , _mMarkdownSource = cp^.cpMarkdownSource + , _mUser = + case cp^.cpUserOverride of + Just n | cp^.cpType == NormalPost -> UserOverride (n <> "[BOT]") + _ -> maybe NoUser UserI $ cp^.cpUser + , _mDate = cp^.cpDate + , _mType = CP $ cp^.cpType + , _mPending = cp^.cpPending + , _mDeleted = cp^.cpDeleted + , _mAttachments = cp^.cpAttachments + , _mInReplyToMsg = + case cp^.cpInReplyToPost of + Nothing -> NotAReply + Just pId -> InReplyTo pId + , _mMessageId = Just $ MessagePostId $ cp^.cpPostId + , _mReactions = cp^.cpReactions + , _mOriginalPost = Just $ cp^.cpOriginalPost + , _mFlagged = False + , _mChannelId = Just $ cp^.cpChannelId + } + + newMessageOfType :: Text -> MessageType -> ServerTime -> Message newMessageOfType text typ d = Message { _mText = getBlocks text @@ -347,10 +415,11 @@ -- unified into the following, but that will require TypeFamilies or -- similar to relate d and r SeqDirection types. For now, it's -- simplier to just have two API endpoints. -splitMsgSeqOn :: (SeqDirection d, SeqDirection r) => - (Message -> Bool) - -> DirectionalSeq d Message - -> (Maybe Message, (DirectionalSeq r Message, DirectionalSeq d Message)) +splitMsgSeqOn :: SeqDirection d => + (Message -> Bool) + -> DirectionalSeq d Message + -> (Maybe Message, (DirectionalSeq (ReverseDirection d) Message, + DirectionalSeq d Message)) splitMsgSeqOn f msgs = let (removed, remaining) = dirSeqBreakl f msgs devomer = DSeq $ Seq.reverse $ dseq removed @@ -382,72 +451,67 @@ >>= Just . Seq.index (dseq msgs) -- | Look forward for the first Message with an ID that follows the --- specified PostId +-- specified Id and return it. If no input Id supplied, get the +-- latest (most recent chronologically) Message in the input set. +getNextMessage :: Maybe MessageId -> Messages -> Maybe Message +getNextMessage = getRelMessageId + +-- | Look backward for the first Message with an ID that follows the +-- specified MessageId and return it. If no input MessageId supplied, +-- get the latest (most recent chronologically) Message in the input +-- set. +getPrevMessage :: Maybe MessageId -> Messages -> Maybe Message +getPrevMessage mId = getRelMessageId mId . reverseMessages + +-- | Look forward for the first Message with an ID that follows the +-- specified MessageId and return that found Message's ID; if no input +-- MessageId is specified, return the latest (most recent +-- chronologically) MessageId (if any) in the input set. getNextMessageId :: Maybe MessageId -> Messages -> Maybe MessageId -getNextMessageId = getRelMessageId foldl +getNextMessageId mId = _mMessageId <=< getNextMessage mId -- | Look backwards for the first Message with an ID that comes before --- the specified MessageId. +-- the specified MessageId and return that found Message's ID; if no +-- input MessageId is specified, return the latest (most recent +-- chronologically) MessageId (if any) in the input set. getPrevMessageId :: Maybe MessageId -> Messages -> Maybe MessageId -getPrevMessageId = getRelMessageId $ foldr . flip +getPrevMessageId mId = _mMessageId <=< getPrevMessage mId -- | Look forward for the first Message with an ID that follows the --- specified PostId +-- specified PostId and return that found Message's PostID; if no +-- input PostId is specified, return the latest (most recent +-- chronologically) PostId (if any) in the input set. getNextPostId :: Maybe PostId -> Messages -> Maybe PostId -getNextPostId = getRelPostId foldl +getNextPostId pid = messagePostId <=< getNextMessage (MessagePostId <$> pid) -- | Look backwards for the first Post with an ID that comes before -- the specified PostId. getPrevPostId :: Maybe PostId -> Messages -> Maybe PostId -getPrevPostId = getRelPostId $ foldr . flip +getPrevPostId pid = messagePostId <=< getPrevMessage (MessagePostId <$> pid) --- | Find the next MessageId after the specified MessageId (if there is --- one) by folding in the specified direction -getRelMessageId :: ((Either MessageId (Maybe MessageId) - -> Message - -> Either MessageId (Maybe MessageId)) - -> Either MessageId (Maybe MessageId) - -> Messages - -> Either MessageId (Maybe MessageId)) - -> Maybe MessageId - -> Messages - -> Maybe MessageId -getRelMessageId folD jp = case jp of - Nothing -> \msgs -> (getLatestPostMsg msgs >>= _mMessageId) - Just p -> either (const Nothing) id . folD fnd (Left p) - where fnd = either fndp fndnext - fndp c v = if v^.mMessageId == Just c then Right Nothing else Left c - idOfPost m = if m^.mDeleted then Nothing else m^.mMessageId - fndnext n m = Right (n <|> idOfPost m) --- | Find the next PostId after the specified PostId (if there is --- one) by folding in the specified direction -getRelPostId :: ((Either PostId (Maybe PostId) - -> Message - -> Either PostId (Maybe PostId)) - -> Either PostId (Maybe PostId) - -> Messages - -> Either PostId (Maybe PostId)) - -> Maybe PostId - -> Messages - -> Maybe PostId -getRelPostId folD jp = case jp of - Nothing -> \msgs -> do - latest <- getLatestPostMsg msgs - mId <- latest^.mMessageId - case mId of - MessagePostId pId -> return pId - _ -> Nothing - Just p -> either (const Nothing) id . folD fnd (Left p) - where fnd = either fndp fndnext - fndp c v = if v^.mMessageId == Just (MessagePostId c) then Right Nothing else Left c - idOfPost m = if m^.mDeleted - then Nothing - else case m^.mMessageId of - Just (MessagePostId pId) -> Just pId - _ -> Nothing - fndnext n m = Right (n <|> idOfPost m) +getRelMessageId :: SeqDirection dir => + Maybe MessageId + -> DirectionalSeq dir Message + -> Maybe Message +getRelMessageId mId = + let isMId = const ((==) mId . _mMessageId) <$> mId + in getRelMessage isMId +-- | Internal worker function to return a different user message in +-- relation to either the latest point or a specific message. +getRelMessage :: SeqDirection dir => + Maybe (Message -> Bool) + -> DirectionalSeq dir Message + -> Maybe Message +getRelMessage matcher msgs = + let after = case matcher of + Just matchFun -> case splitMsgSeqOn matchFun msgs of + (_, (_, ms)) -> ms + Nothing -> msgs + in withDirSeqHead id $ filterMessages validSelectableMessage after + + -- | Find the most recent message that is a Post (as opposed to a -- local message) (if any). getLatestPostMsg :: Messages -> Maybe Message @@ -455,6 +519,14 @@ case viewr $ dropWhileR (not . validUserMessage) (dseq msgs) of EmptyR -> Nothing _ :> m -> Just m + +-- | Find the oldest message that is a message with an ID. +getEarliestSelectableMessage :: Messages -> Maybe Message +getEarliestSelectableMessage msgs = + case viewl $ dropWhileL (not . validSelectableMessage) (dseq msgs) of + EmptyL -> Nothing + m :< _ -> Just m + -- | Find the most recent message that is a message with an ID. getLatestSelectableMessage :: Messages -> Maybe Message diff --git a/src/Types/Posts.hs b/src/Types/Posts.hs --- a/src/Types/Posts.hs +++ b/src/Types/Posts.hs @@ -70,7 +70,7 @@ { _cmText :: Text , _cmDate :: ServerTime , _cmType :: ClientMessageType - } deriving (Eq, Show) + } deriving (Show) -- | Create a new 'ClientMessage' value. This is a message generated -- by this Matterhorn client and not by (or visible to) the Server. @@ -92,8 +92,13 @@ | Error | DateTransition | NewMessagesTransition - | UnknownGap -- ^ marks region where server may have messages unknown locally - deriving (Eq, Show) + | UnknownGapBefore -- ^ a region where the server may have + -- messages before the given timestamp that are + -- not known locally by this client + | UnknownGapAfter -- ^ a region where server may have messages + -- after the given timestamp that are not known + -- locally by this client + deriving (Show) -- ** 'ClientMessage' Lenses diff --git a/src/Types/UserNames.hs b/src/Types/UserNames.hs new file mode 100644 --- /dev/null +++ b/src/Types/UserNames.hs @@ -0,0 +1,70 @@ +module Types.UserNames + ( findUsernames + , isNameFragment + , takeWhileNameFragment + ) +where + +import qualified Cheapskate as C +import Data.Char ( isAlpha ) +import qualified Data.Foldable as F +import qualified Data.Set as S +import qualified Data.Text as T + +import Prelude () +import Prelude.MH + + +findUsernames :: C.Blocks -> S.Set T.Text +findUsernames = S.unions . F.toList . fmap blockFindUsernames + +blockFindUsernames :: C.Block -> S.Set T.Text +blockFindUsernames (C.Para is) = + inlineFindUsernames $ F.toList is +blockFindUsernames (C.Header _ is) = + inlineFindUsernames $ F.toList is +blockFindUsernames (C.Blockquote bs) = + findUsernames bs +blockFindUsernames (C.List _ _ bs) = + S.unions $ F.toList $ findUsernames <$> bs +blockFindUsernames _ = + mempty + +inlineFindUsernames :: [C.Inline] -> S.Set T.Text +inlineFindUsernames [] = mempty +inlineFindUsernames (C.Str "@" : rest) = + let (strs, remaining) = takeWhileNameFragment rest + in if null strs + then inlineFindUsernames remaining + else S.insert (T.concat $ getInlineStr <$> strs) $ inlineFindUsernames remaining +inlineFindUsernames (_ : rest) = + inlineFindUsernames rest + +getInlineStr :: C.Inline -> T.Text +getInlineStr (C.Str s) = s +getInlineStr _ = "" + +takeWhileNameFragment :: [C.Inline] -> ([C.Inline], [C.Inline]) +takeWhileNameFragment [] = ([], []) +takeWhileNameFragment rest = + let (strs, remaining) = break (not . isNameFragment) rest + -- Does the last element in strs start with a letter? If + -- not, move it to the remaining list. This avoids pulling + -- punctuation-only tokens into usernames, e.g. "Hello, + -- @foobar." + (strs', remaining') = + if length strs <= 1 + then (strs, remaining) + else let (initStrs, [lastStr]) = splitAt (length strs - 1) strs + in if isAlpha $ T.head $ getInlineStr lastStr + then (strs, remaining) + else (initStrs, lastStr : remaining) + in (strs', remaining') + +isValidNameChar :: Char -> Bool +isValidNameChar c = isAlpha c || c == '_' || c == '.' || c == '-' + +isNameFragment :: C.Inline -> Bool +isNameFragment (C.Str t) = + not (T.null t) && isValidNameChar (T.head t) +isNameFragment _ = False diff --git a/src/Types/Users.hs b/src/Types/Users.hs --- a/src/Types/Users.hs +++ b/src/Types/Users.hs @@ -62,7 +62,10 @@ -- | Is this user deleted? userDeleted :: User -> Bool -userDeleted u = userDeleteAt u > userCreateAt u +userDeleted u = + case userCreateAt u of + Nothing -> False + Just c -> userDeleteAt u > c -- | Create a 'UserInfo' value from a Mattermost 'User' value userInfoFromUser :: User -> Bool -> UserInfo diff --git a/test/test_messages.hs b/test/test_messages.hs --- a/test/test_messages.hs +++ b/test/test_messages.hs @@ -523,14 +523,14 @@ counterexample info $ null $ unreverseMessages before , testProperty "remaining after when found at first position" $ \(w', x', y', z') -> - let (_, (_, after)) = splitMessages (w^.mMessageId) msgs + let (_, (_, afterMsgs)) = splitMessages (w^.mMessageId) msgs msgs = makeMsgs inpl inpl = [w, x, y, z] [w, x, y, z] = setDateOrderMessages [w', x', y', z'] - info = show (idlist inpl) <> " ==> " <> (show $ idlist after) + info = show (idlist inpl) <> " ==> " <> (show $ idlist afterMsgs) in validIds inpl && uniqueIds inpl ==> counterexample info $ - idlist (tail inpl) == idlist after + idlist (tail inpl) == idlist afterMsgs , testProperty "found at last position" $ \(w', x', y', z') -> @@ -554,13 +554,13 @@ , testProperty "no after when found at last position" $ \(w', x', y', z') -> - let (_, (_, after)) = splitMessages (z^.mMessageId) msgs + let (_, (_, afterMsgs)) = splitMessages (z^.mMessageId) msgs msgs = makeMsgs inpl inpl = [w, x, y, z] [w, x, y, z] = setDateOrderMessages [w', x', y', z'] - info = show (idlist inpl) <> " ==> " <> (show $ idlist after) + info = show (idlist inpl) <> " ==> " <> (show $ idlist afterMsgs) in validIds inpl && uniqueIds inpl ==> - counterexample info $ null after + counterexample info $ null afterMsgs , testProperty "found at midpoint position" $ \(v', w', x', y', z') -> @@ -586,15 +586,15 @@ , testProperty "after when found at midpoint position" $ \(v', w', x', y', z') -> - let (_, (_, after)) = splitMessages (x^.mMessageId) msgs + let (_, (_, afterMsgs)) = splitMessages (x^.mMessageId) msgs msgs = makeMsgs inpl inpl = [v, w, x, y, z] [v, w, x, y, z] = setDateOrderMessages [v', w', x', y', z'] - info = show (idlist inpl) <> " ==> " <> (show $ idlist after) + info = show (idlist inpl) <> " ==> " <> (show $ idlist afterMsgs) in validIds inpl && uniqueIds inpl ==> counterexample info $ - idlist [y, z] == idlist after + idlist [y, z] == idlist afterMsgs ]