diff --git a/CHANGELOG.md b/CHANGELOG.md --- a/CHANGELOG.md +++ b/CHANGELOG.md @@ -1,3 +1,50 @@ + +40600.0.0 +========= + +This release supports Mattermost server version 4.6. + +New features: + * Rebindable keys are now supported! See `/help keybindings` for + details. Matterhorn also checks for conflicting bindings on startup. + * The user status list now supports the Do Not Disturb status (shown as + `×`). + * User typing notifications are now supported. These are off by default + but can be enabled with the `showTypingIndicator` configuration + setting. Enabling the feature causes Matterhorn to produce such + notifications for the server and to display typing indications from + other users. Thanks to Abhinav Sarkar for this feature! + * Matterhorn now remembers which channel was visited when the client is + closed and returns to that channel on startup. Thanks to Abhinav + Sarkar for this feature! + +New commands: + * `/message-preview` now toggles message preview mode in addition to + default `M-p` keybinding. + +Bug fixes: + * New post reactions no longer cause a post to be indicated as + "(edited)" (#333) + +UI changes: + * The channel list shown by `/join` now also displays the channel + purpose for each channel when possible. + +Performance improvements: + * Matterhorn now has much lower input latency on servers with very + large numbers of users due to user list rendering performance + improvements. + +Miscellaneous: + * This release now uses only version 4 API endpoints, consistent with + the upstream deprecation of version 3 API endpoints in the 4.6 + release. + * Startup requests are now performed concurrently to improve + performance (#347, thanks to Abhinav Sarkar) + * Channel header strings containing newlines are now rendered more + effectively: newlines are converted to spaces. This behavior more + closely matches the web client, too. + 40400.0.0 ========= @@ -64,7 +111,6 @@ * New channels will not appear twice in the sidebar (fixes #327) * New messages to previously-hidden group channels will cause the group channel to be shown again (fixes #326) - Package changes: * PRACTICES.md is now listed in extra-doc-files. diff --git a/README.md b/README.md --- a/README.md +++ b/README.md @@ -1,4 +1,4 @@ -[![Build +[![Hackage](https://img.shields.io/hackage/v/matterhorn.svg)](https://hackage.haskell.org/package/matterhorn) [![Build Status](https://travis-ci.org/matterhorn-chat/matterhorn.svg?branch=master)](https://travis-ci.org/matterhorn-chat/matterhorn) ![](logo.png) @@ -7,6 +7,12 @@ ![](screenshots/screenshot-00.png) +# New Release Notifications + +Get notified about new Matterhorn releases by following our Twitter account! + +[https://twitter.com/matterhorn_chat](https://twitter.com/matterhorn_chat) + # Quick Start We provide pre-built binary releases for some platforms. Please see the @@ -57,8 +63,8 @@ The user interface has three main areas: * Left: list of channels you're in, and list of users in your team and - their statuses (`+` means online, `-` means away, and an absent sigil - means offline) + their statuses (`+` means online, `-` means away, `×` means Do Not + Disturb, and an absent sigil means offline) * Right: messages in the current channel * Bottom: editing area for writing, editing, and replying to messages @@ -87,9 +93,9 @@ To edit your current message in an external editor (`$EDITOR`), use the default binding of `M-k`. -To preview the message you're about to send (e.g. to check on how your -Markdown syntax will be rendered), toggle preview mode with the default -binding `M-p`. +To preview the message you're about to send while you compose it (e.g. +to check on how your Markdown syntax will be rendered), toggle preview +mode with the default binding `M-p`. To change channels, use `/focus` or one of the default bindings `C-n` (next channel), `C-p` (previous channel), `C-g` (fast channel switch). @@ -147,6 +153,7 @@ * Support for SOCKS 4 and 5 proxies via the `ALL_PROXY`, `HTTP_PROXY`, and `HTTPS_PROXY` environment variables. (Plain HTTP proxies are not yet supported.) +* Multiple color themes with color theme customization support # Spell Checking Support diff --git a/matterhorn.cabal b/matterhorn.cabal --- a/matterhorn.cabal +++ b/matterhorn.cabal @@ -1,5 +1,5 @@ name: matterhorn -version: 40400.0.0 +version: 40600.0.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 @@ -55,6 +55,7 @@ InputHistory IOUtil Events + Events.Keybindings Events.ShowHelp Events.MessageSelect Events.Main @@ -66,9 +67,13 @@ Events.LeaveChannelConfirm Events.DeleteChannelConfirm HelpTopics + LastRunState Scripts + TimeUtils Types Types.Channels + Types.DirectionalSeq + Types.KeyEvents Types.Messages Types.Users Types.Posts @@ -82,10 +87,11 @@ ScopedTypeVariables ghc-options: -Wall -threaded build-depends: base >=4.8 && <5 - , mattermost-api == 40400.0.0 + , mattermost-api == 40600.0.0 , base-compat >= 0.9 && < 0.10 , unordered-containers >= 0.2 && < 0.3 , containers >= 0.5.7 && < 0.6 + , semigroups >= 0.18 && < 0.19 , connection >= 0.2 && < 0.3 , text >= 1.2 && < 1.3 , bytestring >= 0.10 && < 0.11 @@ -93,8 +99,9 @@ , config-ini >= 0.1.2 && < 0.2 , process >= 1.4 && < 1.7 , microlens-platform >= 0.3 && < 0.4 - , brick >= 0.29 && < 0.30 - , vty >= 5.18 && < 5.19 + , brick >= 0.32 && < 0.33 + , vty >= 5.19 && < 5.20 + , word-wrap >= 0.4.0 && < 0.5 , transformers >= 0.4 && < 0.6 , text-zipper >= 0.10 && < 0.11 , time >= 1.6 && < 1.9 @@ -114,6 +121,10 @@ , stm-delay >= 0.1 && < 0.2 , unix >= 2.7.1.0 && < 2.7.3.0 , skylighting >= 0.3.3.1 && < 0.4 + , timezone-olson >= 0.1.7 && < 0.2 + , timezone-series >= 0.1.6.1 && < 0.2 + , aeson >= 1.2.3.0 && < 1.3 + , async >= 2.0 && < 2.2 default-language: Haskell2010 test-suite test_messages @@ -123,6 +134,7 @@ , Message_QCA , Types.Messages , Types.Posts + , Types.DirectionalSeq default-language: Haskell2010 default-extensions: OverloadedStrings , ScopedTypeVariables @@ -130,7 +142,7 @@ hs-source-dirs: src, test build-depends: base >=4.7 && <5 , base-compat >= 0.9 && < 0.10 - , brick >= 0.29 && < 0.30 + , brick >= 0.32 && < 0.33 , bytestring >= 0.10 && < 0.11 , cheapskate >= 0.1 && < 0.2 , checkers >= 0.4 && < 0.5 @@ -141,8 +153,8 @@ , filepath >= 1.4 && < 1.5 , hashable >= 1.2 && < 1.3 , Hclip >= 3.0 && < 3.1 - , mattermost-api == 40400.0.0 - , mattermost-api-qc == 40400.0.0 + , mattermost-api == 40600.0.0 + , mattermost-api-qc == 40600.0.0 , microlens-platform >= 0.3 && < 0.4 , mtl >= 2.2 && < 2.3 , process >= 1.4 && < 1.7 @@ -156,9 +168,11 @@ , text >= 1.2 && < 1.3 , text-zipper >= 0.10 && < 0.11 , time >= 1.6 && < 1.9 + , timezone-olson >= 0.1.7 && < 0.2 + , timezone-series >= 0.1.6.1 && < 0.2 , transformers >= 0.4 && < 0.6 , Unique >= 0.4 && < 0.5 , unordered-containers >= 0.2 && < 0.3 , vector <= 0.12.0.1 - , vty >= 5.18 && < 5.19 + , vty >= 5.19 && < 5.20 , xdg-basedir >= 0.2 && < 0.3 diff --git a/src/App.hs b/src/App.hs --- a/src/App.hs +++ b/src/App.hs @@ -7,8 +7,6 @@ import Prelude.Compat import Brick -import Brick.BChan -import qualified Control.Concurrent.STM as STM import qualified Graphics.Vty as Vty import Lens.Micro.Platform import System.IO (IOMode(WriteMode), openFile, hClose) @@ -17,7 +15,6 @@ import Config import Options import State.Setup -import State.Setup.Threads (startAsyncWorkerThread) import Events import Draw import Types @@ -33,26 +30,20 @@ runMatterhorn :: Options -> Config -> IO ChatState runMatterhorn opts config = do - eventChan <- newBChan 25 - writeBChan eventChan RefreshWebsocketEvent - - requestChan <- STM.atomically STM.newTChan - - startAsyncWorkerThread config requestChan eventChan - logFile <- case optLogLocation opts of Just path -> Just `fmap` openFile path WriteMode Nothing -> return Nothing - st <- setupState logFile config requestChan eventChan + st <- setupState logFile config let mkVty = do vty <- Vty.mkVty Vty.defaultConfig let output = Vty.outputIface vty Vty.setMode output Vty.BracketedPaste True + Vty.setMode output Vty.Hyperlink True return vty - finalSt <- customMain mkVty (Just eventChan) app st + finalSt <- customMain mkVty (Just $ st^.csResources.crEventQueue) app st case finalSt^.csEditState.cedSpellChecker of Nothing -> return () diff --git a/src/Command.hs b/src/Command.hs --- a/src/Command.hs +++ b/src/Command.hs @@ -12,11 +12,12 @@ import Data.Monoid ((<>)) import qualified Data.Text as T import Lens.Micro.Platform -import qualified Network.Mattermost as MM -import qualified Network.Mattermost.Lenses as MM +import qualified Network.Mattermost.Endpoints as MM +import qualified Network.Mattermost.Types as MM import qualified Network.Mattermost.Exceptions as MM import State +import State.Editing (toggleMessagePreview) import State.Common import State.PostListOverlay import Types @@ -72,6 +73,8 @@ , Cmd "remove-user" "Remove a user from the current channel" (TokenArg "username" NoArg) $ \ (uname, ()) -> removeUserFromCurrentChannel uname + , Cmd "message-preview" "Toggle preview of the current message" NoArg $ \_ -> + toggleMessagePreview , Cmd "focus" "Focus on a named channel" (TokenArg "channel" NoArg) $ \ (name, ()) -> changeChannel name @@ -106,14 +109,15 @@ , Cmd "search" "Search for posts with given terms" (LineArg "terms") $ enterSearchResultPostListMode + ] execMMCommand :: T.Text -> T.Text -> MH () execMMCommand name rest = do cId <- use csCurrentChannelId session <- use (csResources.crSession) - myTeamId <- use (csMyTeam.(MM.teamIdL)) em <- use (csEditState.cedEditMode) + tId <- use (csMyTeam.to MM.teamId) let mc = MM.MinCommand { MM.minComChannelId = cId , MM.minComCommand = "/" <> name <> " " <> rest @@ -125,9 +129,10 @@ Replying _ p -> MM.postRootId p <|> (Just $ MM.postId p) Editing p -> MM.postRootId p _ -> Nothing + , MM.minComTeamId = tId } runCmd = liftIO $ do - void $ MM.mmExecute session myTeamId mc + void $ MM.mmExecuteCommand mc session handleHTTP (MM.HTTPResponseException err) = return (Just (T.pack err)) -- XXX: this might be a bit brittle in the future, because it @@ -137,8 +142,12 @@ handleCmdErr (MM.MattermostServerError err) = let (_, msg) = T.breakOn ": " err in return (Just (T.drop 2 msg)) + handleMMErr (MM.MattermostError + { MM.mattermostErrorMessage = msg }) = + return (Just msg) errMsg <- liftIO $ (runCmd >> return Nothing) `Exn.catch` handleHTTP `Exn.catch` handleCmdErr + `Exn.catch` handleMMErr case errMsg of Nothing -> return () Just err -> diff --git a/src/Config.hs b/src/Config.hs --- a/src/Config.hs +++ b/src/Config.hs @@ -12,8 +12,11 @@ import Prelude.Compat import Control.Applicative +import Control.Monad (forM) import Control.Monad.Trans.Except import Data.Ini.Config +import qualified Data.Map.Strict as M +import Data.Maybe (catMaybes, fromMaybe) import qualified Data.Text as T import qualified Data.Text.IO as T import Data.Monoid ((<>)) @@ -23,13 +26,14 @@ import IOUtil import FilePaths import Types +import Types.KeyEvents defaultPort :: Int defaultPort = 443 fromIni :: IniParser Config fromIni = do - section "mattermost" $ do + conf <- section "mattermost" $ do configUser <- fieldMbOf "user" stringField configHost <- fieldMbOf "host" stringField configTeam <- fieldMbOf "team" stringField @@ -51,6 +55,8 @@ (configShowBackground defaultConfig) configShowMessagePreview <- fieldFlagDef "showMessagePreview" (configShowMessagePreview defaultConfig) + configShowTypingIndicator <- fieldFlagDef "showTypingIndicator" + (configShowTypingIndicator defaultConfig) configEnableAspell <- fieldFlagDef "enableAspell" (configEnableAspell defaultConfig) configActivityBell <- fieldFlagDef "activityBell" @@ -62,7 +68,15 @@ fieldFlagDef "unsafeUseUnauthenticatedConnection" False let configAbsPath = Nothing + configUserKeys = mempty return Config { .. } + keys <- sectionMb "keybindings" $ do + fmap (M.fromList . catMaybes) $ forM allEvents $ \ ev -> do + kb <- fieldMbOf (keyEventName ev) parseBindingList + case kb of + Nothing -> return Nothing + Just binding -> return (Just (ev, binding)) + return conf { configUserKeys = fromMaybe mempty keys } backgroundField :: T.Text -> Either String BackgroundInfo backgroundField t = @@ -95,27 +109,29 @@ 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 + 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 - , configActivityBell = False - , configShowBackground = Disabled - , configShowMessagePreview = False - , configEnableAspell = False - , configAspellDictionary = Nothing - , configUnsafeUseHTTP = False - , configChannelListWidth = 20 - , configShowOlderEdits = True + , configActivityBell = False + , configShowBackground = Disabled + , configShowMessagePreview = False + , configEnableAspell = False + , configAspellDictionary = Nothing + , configUnsafeUseHTTP = False + , configChannelListWidth = 20 + , configShowOlderEdits = True + , configUserKeys = mempty + , configShowTypingIndicator = False } findConfig :: Maybe FilePath -> IO (Either String Config) diff --git a/src/Connection.hs b/src/Connection.hs --- a/src/Connection.hs +++ b/src/Connection.hs @@ -5,30 +5,65 @@ import Brick.BChan import Control.Concurrent (forkIO, threadDelay) -import Control.Concurrent.MVar +import qualified Control.Concurrent.STM as STM import Control.Exception (SomeException, catch) import Control.Monad (void) +import Control.Monad.IO.Class (liftIO) +import Data.Int (Int64) +import qualified Data.HashMap.Strict as HM +import Data.Semigroup (Max(..), (<>)) +import Data.Time (UTCTime(..), secondsToDiffTime, getCurrentTime, diffUTCTime) +import Data.Time.Calendar (Day(..)) import Lens.Micro.Platform -import Network.Mattermost.WebSocket +import Network.Mattermost.Types (ChannelId) +import qualified Network.Mattermost.WebSocket as WS +import Constants import Types -connectWebsockets :: ChatState -> IO () -connectWebsockets st = do - let shunt (Left msg) = writeBChan (st^.csResources.crEventQueue) (WebsocketParseError msg) - shunt (Right e) = writeBChan (st^.csResources.crEventQueue) (WSEvent e) - runWS = mmWithWebSocket (st^.csResources.crSession) shunt $ \ _ -> do - writeBChan (st^.csResources.crEventQueue) WebsocketConnect - waitAndQuit st - void $ forkIO $ runWS `catch` handleTimeout 1 st - `catch` handleError 5 st +connectWebsockets :: MH () +connectWebsockets = do + st <- use id + liftIO $ do + let shunt (Left msg) = writeBChan (st^.csResources.crEventQueue) (WebsocketParseError msg) + shunt (Right e) = writeBChan (st^.csResources.crEventQueue) (WSEvent e) + runWS = WS.mmWithWebSocket (st^.csResources.crSession) shunt $ \ws -> do + writeBChan (st^.csResources.crEventQueue) WebsocketConnect + processWebsocketActions st ws 1 HM.empty + void $ forkIO $ runWS `catch` handleTimeout 1 st + `catch` handleError 5 st -waitAndQuit :: ChatState -> IO () -waitAndQuit st = - void (takeMVar (st^.csResources.crQuitCondition)) +-- | Take websocket actions from the websocket action channel in the ChatState and +-- | send them to the server over the websocket. +-- | Takes and propagates the action sequence number which in incremented for +-- | each successful send. +-- | Keeps and propagates a map of channel id to last user_typing notification send time +-- | so that the new user_typing actions are throttled to be send only once in two seconds. +processWebsocketActions :: ChatState -> WS.MMWebSocket -> Int64 -> HM.HashMap ChannelId (Max UTCTime) -> IO () +processWebsocketActions st ws s userTypingLastNotifTimeMap = do + action <- STM.atomically $ STM.readTChan (st^.csResources.crWebsocketActionChan) + if (shouldSendAction action) + then do + WS.mmSendWSAction (st^.csResources.crConn) ws $ convert action + now <- getCurrentTime + processWebsocketActions st ws (s + 1) $ userTypingLastNotifTimeMap' action now + else do + processWebsocketActions st ws s userTypingLastNotifTimeMap + where + convert (UserTyping _ cId pId) = WS.UserTyping s cId pId -handleTimeout :: Int -> ChatState -> MMWebSocketTimeoutException -> IO () + shouldSendAction (UserTyping ts cId _) = + diffUTCTime ts (userTypingLastNotifTime cId) >= (userTypingExpiryInterval / 2 - 0.5) + + userTypingLastNotifTime cId = getMax $ HM.lookupDefault (Max zeroTime) cId userTypingLastNotifTimeMap + + zeroTime = UTCTime (ModifiedJulianDay 0) (secondsToDiffTime 0) + + userTypingLastNotifTimeMap' (UserTyping _ cId _) now = + HM.insertWith (<>) cId (Max now) userTypingLastNotifTimeMap + +handleTimeout :: Int -> ChatState -> WS.MMWebSocketTimeoutException -> IO () handleTimeout seconds st _ = reconnectAfter seconds st handleError :: Int -> ChatState -> SomeException -> IO () diff --git a/src/Constants.hs b/src/Constants.hs --- a/src/Constants.hs +++ b/src/Constants.hs @@ -1,8 +1,15 @@ module Constants ( pageAmount + , userTypingExpiryInterval ) where +import Data.Time (NominalDiffTime) + -- | The number of rows to consider a "page" when scrolling pageAmount :: Int pageAmount = 15 + +-- | The expiry interval in seconds for user typing notifications. +userTypingExpiryInterval :: NominalDiffTime +userTypingExpiryInterval = 5 diff --git a/src/Draw/ChannelList.hs b/src/Draw/ChannelList.hs --- a/src/Draw/ChannelList.hs +++ b/src/Draw/ChannelList.hs @@ -20,6 +20,8 @@ import Brick import Brick.Widgets.Border +import qualified Data.Sequence as Seq +import qualified Data.Foldable as F import qualified Data.HashMap.Strict as HM import Data.Monoid ((<>)) import qualified Data.Text as T @@ -47,9 +49,30 @@ -- -- * The function to retrieve the list of channels for this group -- from the ChatState. +-- +-- The retrieval function is also given an optional integer that +-- indicates the height of the channel list (the amount of screen space +-- available to be used). This is provided as an optimization so that we +-- can avoid rendering all known entries when they wouldn't be visible +-- anyway. Please see 'getDmChannels' for more details. +-- +-- The height value is optional because when we're in channel selection +-- mode, we don't want to optimize away hidden channel list entries. If +-- we were to do that, they wouldn't be checked for matching against the +-- channel selection input. So in that case 'Nothing' is given as the +-- channel list height. But otherwise when we're not in that mode we +-- want to skip rendering hidden entries. (Ideally we wouldn't need this +-- hack at all and could be smart about which entries to show regardless +-- of mode, but right now we use a Brick viewport to make scrolling the +-- channel list easy, but that doesn't give us much control over which +-- entries to skip.) +-- +-- Lastly, this functionality uses Sequences instead of lists to +-- facilitate efficient take/drop operations when the optimization +-- mentioned above is in effect. channelListGroups :: [ ( GroupName , Getting ChannelSelectMap ChatState ChannelSelectMap - , ChatState -> [ChannelListEntry] + , ChatState -> Maybe Int -> Seq.Seq ChannelListEntry ) ] channelListGroups = [ ("Channels", csChannelSelectState.channelMatches, getOrdinaryChannels) @@ -67,27 +90,39 @@ -- render the ChannelList sidebar. renderChannelList :: ChatState -> Widget Name renderChannelList st = - let maybeViewport = if hasActiveChannelSelection st - then id -- no viewport scrolling when actively selecting a channel - else viewport ChannelList Vertical - selMatch = st^.csChannelSelectState.selectedMatch - renderedGroups = if hasActiveChannelSelection st - then renderChannelGroup (renderChannelSelectListEntry selMatch) <$> selectedGroupEntries - else renderChannelGroup renderChannelListEntry <$> plainGroupEntries - plainGroupEntries (n, _m, f) = (n, f st) - selectedGroupEntries (n, m, f) = (n, foldr (addSelectedChannel m) [] $ f st) - addSelectedChannel m e s = case HM.lookup (entryLabel e) (st^.m) of - Just y -> SCLE e y : s - Nothing -> s - in maybeViewport $ vBox $ concat $ renderedGroups <$> channelListGroups + Widget Fixed Greedy $ do + ctx <- getContext + let maybeViewport = + if hasActiveChannelSelection st + then id -- no viewport scrolling when actively selecting a channel + else viewport ChannelList Vertical + selMatch = st^.csChannelSelectState.selectedMatch + renderedGroups = + if hasActiveChannelSelection st + then renderChannelGroup (renderChannelSelectListEntry selMatch) <$> + selectedGroupEntries + else renderChannelGroup renderChannelListEntry <$> plainGroupEntries + plainGroupEntries (n, _m, f) = + (n, f st (Just $ ctx^.availHeightL)) + selectedGroupEntries (n, m, f) = + (n, F.foldr (addSelectedChannel m) mempty $ f st Nothing) + addSelectedChannel m e s = + case HM.lookup (entryLabel e) (st^.m) of + Just y -> SCLE e y Seq.<| s + Nothing -> s + + render $ maybeViewport $ vBox $ vBox <$> + F.toList <$> (F.toList $ renderedGroups <$> channelListGroups) + -- | Renders a specific group, given the name of the group and the -- list of entries in that group (which are expected to be either -- ChannelListEntry or SelectedChannelListEntry elements). -renderChannelGroup :: (a -> Widget Name) -> (GroupName, [a]) -> [Widget Name] +renderChannelGroup :: (a -> Widget Name) -> (GroupName, Seq.Seq a) -> Seq.Seq (Widget Name) renderChannelGroup eRender (groupName, entries) = - let header label = hBorderWithLabel $ withDefAttr channelListHeaderAttr $ txt label - in header groupName : (eRender <$> entries) + let header label = hBorderWithLabel $ + withDefAttr channelListHeaderAttr $ txt label + in header groupName Seq.<| (eRender <$> entries) -- | Internal record describing each channel entry and its associated -- attributes. This is the object passed to the rendering function so @@ -122,7 +157,7 @@ | otherwise -> id entryWidget = case entryUserStatus entry of Just Offline -> withDefAttr clientMessageAttr . txt - Just _ -> colorUsername + Just _ -> colorUsername (entryLabel entry) Nothing -> txt decorateMentions | entryMentions entry > 9 = @@ -160,38 +195,60 @@ -- | Extract the names and information about normal channels to be -- displayed in the ChannelList sidebar. -getOrdinaryChannels :: ChatState -> [ChannelListEntry] -getOrdinaryChannels st = - [ ChannelListEntry sigil n unread mentions recent current Nothing +getOrdinaryChannels :: ChatState -> Maybe Int -> Seq.Seq ChannelListEntry +getOrdinaryChannels st _ = + Seq.fromList [ ChannelListEntry sigil n unread mentions recent current Nothing | n <- (st ^. csNames . cnChans) , let Just chan = st ^. csNames . cnToChanId . at n unread = hasUnread st chan - recent = Just chan == st^.csRecentChannel + recent = isRecentChannel st chan current = isCurrentChannel st chan sigil = case st ^. csEditState.cedLastChannelInput.at chan of - Nothing -> T.singleton normalChannelSigil - Just ("", _) -> T.singleton normalChannelSigil + Nothing -> normalChannelSigil + Just ("", _) -> normalChannelSigil _ -> "»" mentions = maybe 0 id (st^?csChannel(chan).ccInfo.cdMentionCount) ] -- | Extract the names and information about Direct Message channels -- to be displayed in the ChannelList sidebar. -getDmChannels :: ChatState -> [ChannelListEntry] -getDmChannels st = - [ ChannelListEntry sigil uname unread mentions recent current (Just $ u^.uiStatus) - | u <- sortedUserList st - , let sigil = - case do { cId <- m_chanId; st^.csEditState.cedLastChannelInput.at cId } of - Nothing -> T.singleton $ userSigilFromInfo u - Just ("", _) -> T.singleton $ userSigilFromInfo u - _ -> "»" -- shows that user has a message in-progress - uname = u^.uiName - recent = maybe False ((== st^.csRecentChannel) . Just) m_chanId - m_chanId = st^.csNames.cnToChanId.at (u^.uiName) - unread = maybe False (hasUnread st) m_chanId - current = maybe False (isCurrentChannel st) m_chanId - mentions = case m_chanId of - Just cId -> maybe 0 id (st^?csChannel(cId).ccInfo.cdMentionCount) - Nothing -> 0 - ] +-- +-- This function takes advantage of the channel height, when given, by +-- only returning enough entries to guarantee that we fill the channel +-- list. For example, if the list is N rows high, this function will +-- return at most 2N channel list entries. It does this, rather than +-- return them all, to avoid rendering (potentially thousands of) +-- entries that won't be visible on the screen anyway, and that turns +-- out to be a big performance win on servers with thousands of users. +-- We return *twice* the number of required entries to ensure that no +-- matter where the selected channel is within the set of returned +-- entries, there are enough entries before and after the selected +-- channel to get the Brick viewport to position the final result in a +-- way that is natural. +getDmChannels :: ChatState -> Maybe Int -> Seq.Seq ChannelListEntry +getDmChannels st height = + let es = Seq.fromList + [ ChannelListEntry (T.cons sigil " ") uname unread + mentions recent current (Just $ u^.uiStatus) + | u <- sortedUserList st + , let sigil = + case do { cId <- m_chanId; st^.csEditState.cedLastChannelInput.at cId } of + Nothing -> userSigilFromInfo u + Just ("", _) -> userSigilFromInfo u + _ -> '»' -- shows that user has a message in-progress + uname = u^.uiName + recent = maybe False (isRecentChannel st) m_chanId + m_chanId = st^.csNames.cnToChanId.at (u^.uiName) + unread = maybe False (hasUnread st) m_chanId + current = maybe False (isCurrentChannel st) m_chanId + mentions = case m_chanId of + Just cId -> maybe 0 id (st^?csChannel(cId).ccInfo.cdMentionCount) + Nothing -> 0 + ] + (h, t) = Seq.breakl entryIsCurrent es + in case height of + Nothing -> es + Just height' -> if null t + then Seq.take height' h + else Seq.drop (length h - height') h <> + Seq.take height' t diff --git a/src/Draw/JoinChannel.hs b/src/Draw/JoinChannel.hs --- a/src/Draw/JoinChannel.hs +++ b/src/Draw/JoinChannel.hs @@ -11,12 +11,14 @@ import Brick.Widgets.List import Brick.Widgets.Center import Brick.Widgets.Border +import qualified Data.Text as T import Data.Monoid ((<>)) import Lens.Micro.Platform ((^.)) import qualified Data.Vector as V - -import Network.Mattermost (Channel) -import Network.Mattermost.Lenses (channelDisplayNameL, channelNameL) +import Text.Wrap ( defaultWrapSettings, preserveIndentation ) +import Network.Mattermost.Types (Channel) +import Network.Mattermost.Lenses ( channelDisplayNameL , channelNameL + , channelPurposeL ) import Types import Themes @@ -47,4 +49,8 @@ renderJoinListItem :: Bool -> Channel -> Widget Name renderJoinListItem _ chan = - padRight Max $ txt $ chan^.channelNameL <> " (" <> chan^.channelDisplayNameL <> ")" + let baseStr = chan^.channelNameL <> " (" <> chan^.channelDisplayNameL <> ")" + s = baseStr <> "\n " <> (T.strip $ chan^.channelPurposeL) + in vLimit 2 $ + txtWrapWith (defaultWrapSettings { preserveIndentation = True }) s <+> + (fill ' ') diff --git a/src/Draw/Main.hs b/src/Draw/Main.hs --- a/src/Draw/Main.hs +++ b/src/Draw/Main.hs @@ -15,46 +15,45 @@ import Control.Monad.Trans.Reader (withReaderT) import Data.Time.Clock (UTCTime(..)) import Data.Time.Calendar (fromGregorian) -import Data.Time.Format ( formatTime - , defaultTimeLocale ) -import Data.Time.LocalTime ( TimeZone, utcToLocalTime - , localTimeToUTC, localDay - , LocalTime(..), midnight ) +import Data.Time.LocalTime.TimeZone.Series (TimeZoneSeries) import qualified Data.Sequence as Seq import qualified Data.Set as S import qualified Data.Foldable as F import Data.List (intersperse) import Data.Maybe (catMaybes, isJust) import Data.Monoid ((<>)) -import qualified Data.Set as Set import Data.Text (Text) import qualified Data.Text as T import Data.Text.Zipper (cursorPosition, insertChar, getText, gotoEOL) import Data.Char (isSpace, isPunctuation) import Lens.Micro.Platform -import Network.Mattermost +import Network.Mattermost.Types (ChannelId, Type(Direct), ServerTime(..)) import Network.Mattermost.Lenses import qualified Graphics.Vty as Vty +import Draw.ChannelList (renderChannelList) +import Draw.Messages +import Draw.Util import Markdown import State import Themes +import TimeUtils (justAfter, justBefore) import Types import Types.Channels ( NewMessageIndicator(..) , ChannelState(..) , ClientChannel , ccInfo, ccContents - , cdCurrentState + , cdCurrentState, cdTypingUsers , cdName, cdType, cdHeader, cdMessages , findChannelById) -import Types.Posts import Types.Messages +import Types.Posts import Types.Users -import Draw.ChannelList (renderChannelList) -import Draw.Messages -import Draw.Util +import Types.KeyEvents +import Events.Keybindings +import Events.MessageSelect previewFromInput :: T.Text -> T.Text -> Maybe Message previewFromInput _ s | s == T.singleton cursorSentinel = Nothing @@ -71,7 +70,7 @@ then Nothing else Just $ Message { _mText = getBlocks content , _mUserName = Just uname - , _mDate = UTCTime (fromGregorian 1970 1 1) 0 + , _mDate = ServerTime $ UTCTime (fromGregorian 1970 1 1) 0 -- The date is not used for preview -- rendering, but we need to provide one. -- Ideally we'd just today's date, but the @@ -98,15 +97,17 @@ -- misspelling list. deriving (Show) -drawEditorContents :: UserSet -> ChannelSet -> ChatState -> [T.Text] -> Widget Name -drawEditorContents uSet cSet st = +drawEditorContents :: ChatState -> HighlightSet -> [T.Text] -> Widget Name +drawEditorContents st hs = let noHighlight = txt . T.unlines in case st^.csEditState.cedSpellChecker of Nothing -> noHighlight Just _ -> case S.null (st^.csEditState.cedMisspellings) of True -> noHighlight - False -> doHighlightMisspellings uSet cSet (st^.csEditState.cedMisspellings) + False -> doHighlightMisspellings + hs + (st^.csEditState.cedMisspellings) -- | This function takes a set of misspellings from the spell -- checker, the editor lines, and builds a rendering of the text with @@ -159,11 +160,11 @@ -- because 1) the user's input might not be valid markdown and 2) even -- if we did that, we'd still have to do this tokenization operation to -- annotate misspellings and reconstruct the user's raw input. -doHighlightMisspellings :: UserSet -> ChannelSet -> S.Set T.Text -> [T.Text] -> Widget Name -doHighlightMisspellings uSet cSet misspellings contents = +doHighlightMisspellings :: HighlightSet -> S.Set T.Text -> [T.Text] -> Widget Name +doHighlightMisspellings hSet misspellings contents = -- Traverse the input, gathering non-whitespace into tokens and -- checking if they appear in the misspelling collection - let whitelist = S.union uSet cSet + let whitelist = S.union (hUserSet hSet) (hChannelSet hSet) handleLine t | t == "" = txt " " handleLine t = @@ -227,13 +228,13 @@ in vBox $ handleLine <$> contents -renderUserCommandBox :: UserSet -> ChannelSet -> ChatState -> Widget Name -renderUserCommandBox uSet cSet st = +renderUserCommandBox :: ChatState -> HighlightSet -> Widget Name +renderUserCommandBox st hs = let prompt = txt $ case st^.csEditState.cedEditMode of Replying _ _ -> "reply> " Editing _ -> "edit> " NewPost -> "> " - inputBox = renderEditor (drawEditorContents uSet cSet st) True (st^.csEditState.cedEditor) + inputBox = renderEditor (drawEditorContents st hs) True (st^.csEditState.cedEditor) curContents = getEditContents $ st^.csEditState.cedEditor multilineContent = length curContents > 1 multilineHints = @@ -249,15 +250,21 @@ Replying msg _ -> let msgWithoutParent = msg & mInReplyToMsg .~ NotAReply in hBox [ replyArrow - , addEllipsis $ renderMessage st Nothing False msgWithoutParent True uSet cSet False + , addEllipsis $ renderMessage MessageData + { mdMessage = msgWithoutParent + , mdParentMessage = Nothing + , mdHighlightSet = hs + , mdEditThreshold = Nothing + , mdShowOlderEdits = False + , mdRenderReplyParent = True + , mdIndentBlocks = False + } ] _ -> emptyWidget commandBox = case st^.csEditState.cedMultiline of False -> - let linesStr = if numLines == 1 - then "line" - else "lines" + let linesStr = "line" <> if numLines == 1 then "" else "s" numLines = length curContents in vLimit 1 $ hBox $ prompt : if multilineContent @@ -271,18 +278,24 @@ True -> vLimit 5 inputBox <=> multilineHints in replyDisplay <=> commandBox -renderChannelHeader :: UserSet -> ChannelSet -> ChatState -> ClientChannel -> Widget Name -renderChannelHeader uSet cSet st chan = +renderChannelHeader :: ChatState -> HighlightSet -> ClientChannel -> Widget Name +renderChannelHeader st hs chan = let chnType = chan^.ccInfo.cdType chnName = chan^.ccInfo.cdName topicStr = chan^.ccInfo.cdHeader userHeader u = let s = T.intercalate " " $ filter (not . T.null) parts parts = [ u^.uiName - , " is" - , u^.uiFirstName + , if (all T.null names) + then mempty + else "is" + ] <> names <> [ + if T.null (u^.uiEmail) + then mempty + else "(" <> u^.uiEmail <> ")" + ] + names = [ u^.uiFirstName , nick , u^.uiLastName - , "(" <> u^.uiEmail <> ")" ] quote n = "\"" <> n <> "\"" nick = maybe "" quote $ u^.uiNickName @@ -297,17 +310,22 @@ Nothing -> mkChannelName (chan^.ccInfo) Just u -> userHeader u _ -> mkChannelName (chan^.ccInfo) - in renderText' uSet cSet (channelNameString <> maybeTopic) + newlineToSpace '\n' = ' ' + newlineToSpace c = c -renderCurrentChannelDisplay :: UserSet -> ChannelSet -> ChatState -> Widget Name -renderCurrentChannelDisplay uSet cSet st = (header <+> conn) <=> messages + in renderText' + hs + (T.map newlineToSpace (channelNameString <> maybeTopic)) + +renderCurrentChannelDisplay :: ChatState -> HighlightSet -> Widget Name +renderCurrentChannelDisplay st hs = (header <+> conn) <=> messages where conn = case st^.csConnectionStatus of Connected -> emptyWidget - Disconnected -> withDefAttr errorMessageAttr (str "[NOT CONNECTED]") + Disconnected -> withDefAttr errorMessageAttr (str "[NOT CONNECTED]") header = withDefAttr channelHeaderAttr $ padRight Max $ - renderChannelHeader uSet cSet st chan + renderChannelHeader st hs chan messages = padTop Max $ padRight (Pad 1) body body = chatText @@ -326,7 +344,7 @@ cached (ChannelMessages cId) $ vBox $ (withDefAttr loadMoreAttr $ hCenter $ str "<< Press C-b to load more messages >>") : - (F.toList $ renderSingleMessage st editCutoff uSet cSet <$> channelMessages) + (F.toList $ renderSingleMessage st hs editCutoff <$> channelMessages) MessageSelect -> renderMessagesWithSelect (st^.csMessageSelect) channelMessages MessageSelectDeleteConfirm -> @@ -351,16 +369,17 @@ in case s of Nothing -> renderLastMessages before Just m -> - unsafeRenderMessageSelection (m, (before, after)) (renderSingleMessage st Nothing uSet cSet) + unsafeRenderMessageSelection (m, (before, after)) (renderSingleMessage st hs Nothing) cutoff = getNewMessageCutoff cId st editCutoff = getEditedMessageCutoff cId st channelMessages = - insertTransitions (getDateFormat st) - (st ^. timeZone) + insertTransitions (getMessageListing cId st) cutoff - (getMessageListing cId st) + (getDateFormat st) + (st ^. timeZone) + renderLastMessages :: RetrogradeMessages -> Widget Name renderLastMessages msgs = Widget Greedy Greedy $ do @@ -381,7 +400,7 @@ False -> do r <- withReaderT relaxHeight $ render $ padRight Max $ - renderSingleMessage st editCutoff uSet cSet msg + renderSingleMessage st hs editCutoff msg return $ r^.imageL cId = st^.csCurrentChannelId @@ -400,10 +419,9 @@ getMessageListing cId st = st ^?! csChannels.folding (findChannelById cId) . ccContents . cdMessages -insertTransitions :: Text -> TimeZone -> Maybe NewMessageIndicator -> Messages -> Messages -insertTransitions datefmt tz cutoff ms = foldr addMessage ms transitions - where transitions = newMessagesT <> dateT - anyNondeletedNewMessages t = +insertTransitions :: Messages -> Maybe NewMessageIndicator -> Text -> TimeZoneSeries -> Messages +insertTransitions ms cutoff = insertDateMarkers $ foldr addMessage ms newMessagesT + where anyNondeletedNewMessages t = isJust $ findLatestUserMessage (not . view mDeleted) (messagesAfter t ms) newMessagesT = case cutoff of Nothing -> [] @@ -414,23 +432,6 @@ Just (NewPostsStartingAt t) | anyNondeletedNewMessages (justBefore t) -> [newMessagesMsg $ justBefore t] | otherwise -> [] - - dateT = fmap dateMsg dateRange - dateRange = let dr = foldr checkDateChange [] ms - in if length dr > 1 then tail dr else [] - checkDateChange m [] | m^.mDeleted = [] - | otherwise = [dayStart $ m^.mDate] - checkDateChange m dl = if dayOf (head dl) == dayOf (m^.mDate) || m^.mDeleted - then dl - else dayStart (m^.mDate) : dl - dayOf = localDay . utcToLocalTime tz - dayStart dt = localTimeToUTC tz $ LocalTime (dayOf dt) $ midnight - justBefore (UTCTime d t) = UTCTime d $ pred t - justAfter (UTCTime d t) = UTCTime d $ succ t - dateMsg d = newMessageOfType (T.pack $ formatTime defaultTimeLocale - (T.unpack datefmt) - (utcToLocalTime tz d)) - (C DateTransition) d newMessagesMsg d = newMessageOfType (T.pack "New Messages") (C NewMessagesTransition) d @@ -462,13 +463,37 @@ hasURLs = numURLs > 0 openUrlsMsg = "open " <> (T.pack $ show numURLs) <> " URL" <> s hasVerb = isJust (findVerbatimChunk (postMsg^.mText)) - options = [ (isReplyable, "r", "reply") - , (\m -> isMine st m && isEditable m, "e", "edit") - , (\m -> isMine st m && isDeletable m, "d", "delete") - , (const hasURLs, "o", openUrlsMsg) - , (const hasVerb, "y", "yank") - , (\m -> not (m^.mFlagged), "f", "flag") - , (\m -> m^.mFlagged , "f", "unflag") + -- make sure these keybinding pieces are up-to-date! + ev e = + let keyconf = st^.csResources.crConfiguration.to configUserKeys + keymap = messageSelectKeybindings keyconf + in T.intercalate "," + [ ppBinding (eventToBinding b) + | KB { kbBindingInfo = Just e' + , kbEvent = b + } <- keymap + , e' == e ] + options = [ ( isReplyable + , ev ReplyMessageEvent + , "reply" ) + , ( \m -> isMine st m && isEditable m + , ev EditMessageEvent + , "edit" ) + , ( \m -> isMine st m && isDeletable m + , ev DeleteMessageEvent + , "delete" ) + , ( const hasURLs + , ev OpenMessageURLEvent + , openUrlsMsg ) + , ( const hasVerb + , ev YankMessageEvent + , "yank" ) + , ( \m -> not (m^.mFlagged) + , ev FlagMessageEvent + , "flag" ) + , ( \m -> m^.mFlagged + , ev FlagMessageEvent + , "unflag" ) ] Just postMsg = getSelectedMessage st @@ -508,9 +533,9 @@ render $ vLimit previewMaxHeight $ viewport MessagePreviewViewport Vertical $ (Widget Fixed Fixed $ return result) -inputPreview :: UserSet -> ChannelSet -> ChatState -> Widget Name -inputPreview uSet cSet st | not $ st^.csShowMessagePreview = emptyWidget - | otherwise = thePreview +inputPreview :: ChatState -> HighlightSet -> Widget Name +inputPreview st hs | not $ st^.csShowMessagePreview = emptyWidget + | otherwise = thePreview where uname = st^.csMe.userUsernameL -- Insert a cursor sentinel into the input text just before @@ -531,12 +556,21 @@ Nothing -> noPreview Just pm -> if T.null curStr then noPreview - else renderMessage st Nothing False pm True uSet cSet True + else renderMessage MessageData + { mdMessage = pm + , mdParentMessage = + getParentMessage st pm + , mdHighlightSet = hs + , mdEditThreshold = Nothing + , mdShowOlderEdits = False + , mdRenderReplyParent = True + , mdIndentBlocks = True + } in (maybePreviewViewport msgPreview) <=> hBorderWithLabel (withDefAttr clientEmphAttr $ str "[Preview ↑]") -userInputArea :: UserSet -> ChannelSet -> ChatState -> Widget Name -userInputArea uSet cSet st = +userInputArea :: ChatState -> HighlightSet -> Widget Name +userInputArea st hs = case st^.csMode of ChannelSelect -> renderChannelSelect st UrlSelect -> hCenter $ hBox [ txt "Press " @@ -550,7 +584,7 @@ , txt " to stop scrolling and resume chatting." ] MessageSelectDeleteConfirm -> renderDeleteConfirm - _ -> renderUserCommandBox uSet cSet st + _ -> renderUserCommandBox st hs renderDeleteConfirm :: Widget Name renderDeleteConfirm = @@ -560,16 +594,15 @@ mainInterface st = vBox [ hBox [hLimit channelListWidth (renderChannelList st), vBorder, mainDisplay] , bottomBorder - , inputPreview uSet cSet st - , userInputArea uSet cSet st + , inputPreview st hs + , userInputArea st hs ] where + hs = getHighlightSet st channelListWidth = configChannelListWidth $ st^.csResources.crConfiguration mainDisplay = case st^.csMode of UrlSelect -> renderUrlList st - _ -> maybeSubdue $ renderCurrentChannelDisplay uSet cSet st - uSet = Set.fromList (st^..csUsers.to allUsers.folded.uiName) - cSet = Set.fromList (st^..csChannels.folded.ccInfo.cdName) + _ -> maybeSubdue $ renderCurrentChannelDisplay st hs bottomBorder = case st^.csMode of MessageSelect -> messageSelectBottomBar st @@ -579,11 +612,22 @@ [ hLimit channelListWidth hBorder , borderElem bsIntersectB , hBorder - , showBusy] + , showTypingUsers + , showBusy + ] + showTypingUsers = case allTypingUsers (st^.csCurrentChannel.ccInfo.cdTypingUsers) of + [] -> emptyWidget + [uId] | Just un <- getUsernameForUserId st uId -> + txt $ un <> " is typing" + [uId1, uId2] | Just un1 <- getUsernameForUserId st uId1 + , Just un2 <- getUsernameForUserId st uId2 -> + txt $ un1 <> " and " <> un2 <> " are typing" + _ -> txt "several people are typing" + showBusy = case st^.csWorkerIsBusy of - Just (Just n) -> txt (T.pack $ "*" <> show n) - Just Nothing -> txt "*" + Just (Just n) -> hLimit 2 hBorder <+> txt (T.pack $ "*" <> show n) + Just Nothing -> hLimit 2 hBorder <+> txt "*" Nothing -> emptyWidget maybeSubdue = if st^.csMode == ChannelSelect @@ -608,14 +652,14 @@ let time = link^.linkTime in attr sel $ vLimit 2 $ (vLimit 1 $ - hBox [ colorUsername (link^.linkUser) + hBox [ let u = (link^.linkUser) in colorUsername u u , if link^.linkName == link^.linkURL then emptyWidget else (txt ": " <+> (renderText $ link^.linkName)) , fill ' ' - , renderDate st time + , renderDate st $ withServerTime time , str " " - , renderTime st time + , renderTime st $ withServerTime time ] ) <=> (vLimit 1 (renderText $ link^.linkURL)) diff --git a/src/Draw/Messages.hs b/src/Draw/Messages.hs --- a/src/Draw/Messages.hs +++ b/src/Draw/Messages.hs @@ -10,9 +10,9 @@ import Data.Monoid ((<>)) import qualified Data.Sequence as Seq import qualified Data.Text as T -import Data.Time.Clock (UTCTime(..)) import qualified Graphics.Vty as Vty import Lens.Micro.Platform +import Network.Mattermost.Types (ServerTime(..)) import Draw.Util import Markdown @@ -29,14 +29,25 @@ -- The `ind` argument specifies an "indicator boundary". Showing -- various indicators (e.g. "edited") is not typically done for -- messages that are older than this boundary value. -renderSingleMessage :: ChatState -> Maybe UTCTime -> UserSet -> ChannelSet -> Message -> Widget Name -renderSingleMessage st ind uSet cSet = - renderChatMessage st ind uSet cSet (withBrackets . renderTime st) +renderSingleMessage :: ChatState -> HighlightSet -> Maybe ServerTime -> Message -> Widget Name +renderSingleMessage st hs ind = + renderChatMessage st hs ind (withBrackets . renderTime st . withServerTime) -renderChatMessage :: ChatState -> Maybe UTCTime -> UserSet -> ChannelSet -> (UTCTime -> Widget Name) -> Message -> Widget Name -renderChatMessage st ind uSet cSet renderTimeFunc msg = +renderChatMessage :: ChatState -> HighlightSet -> Maybe ServerTime -> (ServerTime -> Widget Name) -> Message -> Widget Name +renderChatMessage st hs ind renderTimeFunc msg = let showOlderEdits = configShowOlderEdits $ st^.csResources.crConfiguration - m = renderMessage st ind showOlderEdits msg True uSet cSet True + parent = case msg^.mInReplyToMsg of + NotAReply -> Nothing + InReplyTo pId -> getMessageForPostId st pId + m = renderMessage MessageData + { mdMessage = msg + , mdParentMessage = parent + , mdEditThreshold = ind + , mdHighlightSet = hs + , mdShowOlderEdits = showOlderEdits + , mdRenderReplyParent = True + , mdIndentBlocks = True + } msgAtch = if Seq.null (msg^.mAttachments) then Nothing else Just $ withDefAttr clientMessageAttr $ vBox diff --git a/src/Draw/PostListOverlay.hs b/src/Draw/PostListOverlay.hs --- a/src/Draw/PostListOverlay.hs +++ b/src/Draw/PostListOverlay.hs @@ -9,14 +9,8 @@ import qualified Data.Foldable as F import Data.Monoid ((<>)) import qualified Data.Text as T -import Data.Time.Format ( formatTime - , defaultTimeLocale ) -import Data.Time.LocalTime ( TimeZone, utcToLocalTime - , localTimeToUTC, localDay - , LocalTime(..), TimeOfDay(..) ) -import qualified Data.Set as Set import Lens.Micro.Platform -import Network.Mattermost +import Network.Mattermost.Types import Network.Mattermost.Lenses import Brick @@ -26,7 +20,6 @@ import Themes import Types import Types.Channels -import Types.Posts import Types.Messages import Types.Users import Draw.Main @@ -45,22 +38,6 @@ drawPostListOverlay contents st = drawPostsBox contents st : (forceAttr "invalid" <$> drawMain st) -insertDateHeaders :: T.Text -> TimeZone -> Messages -> Messages -insertDateHeaders datefmt tz ms = foldr addMessage ms dateT - where dateT = fmap dateMsg dateRange - dateRange = foldr checkDateChange [] ms - checkDateChange m [] = [dayStart $ m^.mDate] - checkDateChange m dl = if dayOf (head dl) == dayOf (m^.mDate) - then dl - else dayStart (m^.mDate) : dl - dayOf = localDay . utcToLocalTime tz - dayStart dt = localTimeToUTC tz $ LocalTime (dayOf dt) $ TimeOfDay 23 59 59 - dateMsg d = newMessageOfType - (T.pack $ formatTime defaultTimeLocale - (T.unpack datefmt) - (utcToLocalTime tz d)) - (C DateTransition) d - -- | Draw a PostListOverlay as a floating overlay on top of whatever -- is rendered beneath it drawPostsBox :: PostListContents -> ChatState -> Widget Name @@ -68,20 +45,17 @@ centerLayer $ hLimitWithPadding 10 $ borderWithLabel contentHeader $ padRight (Pad 1) messageListContents where -- The 'window title' of the overlay + hs = getHighlightSet st contentHeader = withAttr channelListHeaderAttr $ txt $ case contents of PostListFlagged -> "Flagged posts" PostListSearch terms searching -> "Search results" <> if searching then ": " <> terms else " (" <> (T.pack . show . length) (st^.csPostListOverlay.postListPosts) <> "): " <> terms - -- User and channel set, for use in message rendering - uSet = Set.fromList (st^..csUsers.to allUsers.folded.uiName) - cSet = Set.fromList (st^..csChannels.folded.ccInfo.cdName) - - messages = insertDateHeaders + messages = insertDateMarkers + (st^.csPostListOverlay.postListPosts) (getDateFormat st) (st^.timeZone) - (st^.csPostListOverlay.postListPosts) -- The overall contents, with a sensible default even if there -- are no messages @@ -100,7 +74,7 @@ -- The render-message function we're using renderMessageForOverlay msg = - let renderedMsg = renderSingleMessage st Nothing uSet cSet msg + let renderedMsg = renderSingleMessage st hs Nothing msg in case msg^.mOriginalPost of -- We should factor out some of the channel name logic at -- some point, but we can do that later diff --git a/src/Draw/ShowHelp.hs b/src/Draw/ShowHelp.hs --- a/src/Draw/ShowHelp.hs +++ b/src/Draw/ShowHelp.hs @@ -9,16 +9,19 @@ import Brick.Widgets.Center (hCenter, centerLayer) import Brick.Widgets.List (listSelectedFocusedAttr) import Lens.Micro.Platform -import Data.List (sortBy, intercalate, sort) -import Data.Ord (comparing) +import Data.List (intercalate, sort) +import Data.Maybe (isNothing) import qualified Data.Map as M import qualified Data.Text as T import Data.Monoid ((<>)) import qualified Graphics.Vty as Vty +import GHC.Exts (sortWith, groupWith) import Network.Mattermost.Version (mmApiVersion) import Themes import Types +import Types.KeyEvents (Binding(..), ppBinding, nonCharKeys, eventToBinding) +import Events.Keybindings import Command import Events.ShowHelp import Events.ChannelScroll @@ -37,23 +40,24 @@ [helpBox (helpTopicViewportName topic) $ helpTopicDraw topic st] helpTopicDraw :: HelpTopic -> ChatState -> Widget Name -helpTopicDraw topic = +helpTopicDraw topic st = case helpTopicScreen topic of - MainHelp -> const mainHelp - ScriptHelp -> const scriptHelp - ThemeHelp -> const themeHelp + MainHelp -> mainHelp (configUserKeys (st^.csResources.crConfiguration)) + ScriptHelp -> scriptHelp + ThemeHelp -> themeHelp + KeybindingHelp -> keybindingHelp (configUserKeys (st^.csResources.crConfiguration)) -mainHelp :: Widget Name -mainHelp = commandHelp +mainHelp :: KeyConfig -> Widget Name +mainHelp kc = commandHelp where commandHelp = vBox $ [ padTop (Pad 1) $ hCenter $ withDefAttr helpEmphAttr $ str mhVersion , hCenter $ withDefAttr helpEmphAttr $ str mmApiVersion , padTop (Pad 1) $ hCenter $ withDefAttr helpEmphAttr $ txt "Help Topics" , drawHelpTopics , padTop (Pad 1) $ hCenter $ withDefAttr helpEmphAttr $ txt "Commands" - , mkCommandHelpText $ sortBy (comparing commandName) commandList + , mkCommandHelpText $ sortWith commandName commandList ] <> - (mkKeybindingHelp <$> keybindSections) + (mkKeybindingHelp <$> keybindSections kc) mkCommandHelpText :: [Cmd] -> Widget Name mkCommandHelpText cs = @@ -75,7 +79,7 @@ drawTopic t = (withDefAttr helpEmphAttr $ txt (padTo topicNameWidth $ helpTopicName t)) <+> txt (helpTopicDescription t) in (padBottom (Pad 1) $ - hCenter $ renderText "These topics can be used with the `/help` command:") <=> + hCenter $ renderText "Learn more about these topics with `/help `:") <=> (hCenter $ vBox allHelpTopics) scriptHelp :: Widget Name @@ -120,6 +124,99 @@ , [ "> *> /sh rot13 Hello, world!*\n" ] ] +keybindingHelp :: KeyConfig -> Widget Name +keybindingHelp kc = 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 $ withDefAttr helpEmphAttr $ txt "Keybinding Syntax" + , padTop (Pad 1) $ hCenter $ hLimit 100 $ vBox validKeys + ] + where 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]** " + , "in your config file and use the event names listed below as " + , "keys and the desired key sequence as values. " + , "See the end of this page for documentation on the valid " + , "syntax for key sequences.\n" + ] + , [ "For example, by default, the keybinding to move to the next " + , "channel in the public channel list is **" + , nextChanBinding + , "**, and the corresponding " + , "previous channel binding is **" + , prevChanBinding + , "**. You might want to remap these " + , "to other keys: say, **C-j** and **C-k**. We can do this with the following " + , "configuration snippet:\n" + ] + , [ "```ini\n" + , "[KEYBINDINGS]\n" + , "focus-next-channel = C-j\n" + , "focus-prev-channel = C-k\n" + , "```\n" + ] + , [ "You can remap a command to more than one key sequence, in which " + , "case any one of the key sequences provided can be used to invoke " + , "the relevant command. To do this, provide the desired bindings as " + , "a comma-separated list. Additionally, some key combinations are " + , "used in multiple modes (such as URL select or help viewing) and " + , "therefore share the same name, such as **cancel** or **scroll-up**.\n" + ] + , [ "Additionally, some keys simply cannot be remapped, mostly in the " + , "case of editing keybindings. If you feel that a particular key " + , "event should be rebindable and isn't, then please feel free to " + , "let us know by posting an issue in the Matterhorn issue tracker.\n" + ] + , [ "It is also possible to entirely unbind a key event by setting its " + , "key to **unbound**, thus avoiding conflicts between default bindings " + , "and new ones:\n" + ] + , [ "```ini\n" + , "[KEYBINDINGS]\n" + , "focus-next-channel = unbound\n" + , "```\n" + ] + , [ "The rebindable key events, along with their **current** " + , "values, are as follows:" + ] + ] + nextChanBinding = ppBinding (head (defaultBindings NextChannelEvent)) + prevChanBinding = ppBinding (head (defaultBindings PrevChannelEvent)) + validKeys = map (padTop (Pad 1) . renderText . mconcat) + [ [ "The syntax used for key sequences consists of zero or more " + , "single-character modifier characters followed by a keystroke " + , "all separated by dashes. The available modifier keys are " + , "**S** for Shift, **C** for Ctrl, **A** for Alt, and **M** for " + , "Meta. So, for example, **" + , ppBinding (Binding [] (Vty.KFun 2)) + , "** is the F2 key pressed with no " + , "modifier keys; **" + , ppBinding (Binding [Vty.MCtrl] (Vty.KChar 'x')) + , "** is Ctrl and X pressed together, " + , "and **" + , ppBinding (Binding [Vty.MShift, Vty.MCtrl] (Vty.KChar 'x')) + , "** is Shift, Ctrl, and X all pressed together. " + , "Although Matterhorn will pretty-print all key combinations " + , "with specific capitalization, the parser is **not** case-sensitive " + , "and will ignore any capitalization." + ] + , [ "Your terminal emulator might not recognize some particular " + , "keypress combinations, or it might reserve certain combinations of " + , "keys for some terminal-specific operation. Matterhorn does not have a " + , "reliable way of testing this, so it is up to you to avoid setting " + , "keybindings that your terminal emulator does not deliver to applications." + ] + , [ "Letter keys, number keys, and function keys are specified with " + , "their obvious name, such as **x** for the X key, **8** for the 8 " + , "key, and **f5** for the F5 key. Other valid keys include: " + , T.intercalate ", " [ "**" <> key <> "**" | key <- nonCharKeys ] + , "." + ] + ] + themeHelp :: Widget a themeHelp = overrideAttr codeAttr helpEmphAttr $ vBox [ padTop (Pad 1) $ hCenter $ withDefAttr helpEmphAttr $ txt "Using Themes" @@ -183,7 +280,18 @@ " * reverseVideo\n" <> " * blink\n" <> " * dim\n" <> - " * bold\n" + " * bold\n" <> + " \n" <> + "In addition, a special value of *default* is possible for either color " <> + "setting of an attribute. This value indicates that the attribute should " <> + "use the terminal emulator's default foreground or background color of " <> + "choice rather than a specific ANSI color." + , padTop (Pad 1) $ hCenter $ withDefAttr helpEmphAttr $ txt "Username Highlighting" + , padTop (Pad 1) $ hCenter $ hLimit 72 $ renderText $ + "Username colors are chosen by hashing each username and then using the hash " <> + "to choose a color from a list of predefined username colors. If you would like " <> + "to change the color in a given entry of this list, we provide the " <> + "\"username.N\" attributes, where N is the index in the username color list." , padTop (Pad 1) $ hCenter $ withDefAttr helpEmphAttr $ txt "Theme Attributes" , padTop (Pad 1) $ hCenter $ hLimit 72 $ renderText $ "This section lists all possible theme attributes for use in customization " <> @@ -213,16 +321,16 @@ hl = ctx^.availHeightL - (2 * vMargin) render $ hLimit wl $ vLimit hl w -keybindSections :: [(T.Text, [Keybinding])] -keybindSections = - [ ("This Help Page", helpKeybindings) - , ("Main Interface", mainKeybindings) - , ("Channel Select Mode", channelSelectKeybindings) - , ("URL Select Mode", urlSelectKeybindings) - , ("Channel Scroll Mode", channelScrollKeybindings) - , ("Message Select Mode", messageSelectKeybindings) +keybindSections :: KeyConfig -> [(T.Text, [Keybinding])] +keybindSections kc = + [ ("This 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) + , ("Flagged Messages", postListOverlayKeybindings kc) ] helpBox :: Name -> Widget Name -> Widget Name @@ -243,46 +351,32 @@ mkKeybindingHelp :: (T.Text, [Keybinding]) -> Widget Name mkKeybindingHelp (sectionName, kbs) = (hCenter $ padTop (Pad 1) $ withDefAttr helpEmphAttr $ txt $ "Keybindings: " <> sectionName) <=> - (hCenter $ vBox $ mkKeybindHelp <$> (sortBy (comparing (ppKbEvent.kbEvent)) kbs)) + (hCenter $ vBox $ mkKeybindHelp <$> (sortWith (ppBinding.eventToBinding.kbEvent) kbs)) mkKeybindHelp :: Keybinding -> Widget Name -mkKeybindHelp (KB desc ev _) = - (withDefAttr helpEmphAttr $ txt $ padTo kbColumnWidth $ ppKbEvent ev) <+> +mkKeybindHelp (KB desc ev _ _) = + (withDefAttr helpEmphAttr $ txt $ padTo kbColumnWidth $ ppBinding $ eventToBinding ev) <+> (vLimit 1 $ hLimit kbDescColumnWidth $ renderText desc <+> fill ' ') -ppKbEvent :: Vty.Event -> T.Text -ppKbEvent (Vty.EvKey k mods) = - T.intercalate "-" $ (ppMod <$> mods) <> [ppKey k] -ppKbEvent _ = "" -ppKey :: Vty.Key -> T.Text -ppKey (Vty.KChar c) = ppChar c -ppKey (Vty.KFun n) = "F" <> (T.pack $ show n) -ppKey Vty.KBackTab = "S-Tab" -ppKey Vty.KEsc = "Esc" -ppKey Vty.KBS = "Backspace" -ppKey Vty.KEnter = "Enter" -ppKey Vty.KUp = "Up" -ppKey Vty.KDown = "Down" -ppKey Vty.KLeft = "Left" -ppKey Vty.KRight = "Right" -ppKey Vty.KHome = "Home" -ppKey Vty.KEnd = "End" -ppKey Vty.KPageUp = "PgUp" -ppKey Vty.KPageDown = "PgDown" -ppKey Vty.KDel = "Del" -ppKey _ = "???" - -ppChar :: Char -> T.Text -ppChar '\t' = "Tab" -ppChar ' ' = "Space" -ppChar c = T.singleton c +mkKeybindEventSectionHelp :: (T.Text, [Keybinding]) -> Widget Name +mkKeybindEventSectionHelp (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) -ppMod :: Vty.Modifier -> T.Text -ppMod Vty.MMeta = "M" -ppMod Vty.MAlt = "A" -ppMod Vty.MCtrl = "C" -ppMod Vty.MShift = "S" +mkKeybindEventHelp :: [Keybinding] -> [Widget Name] +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 _ = [] padTo :: Int -> T.Text -> T.Text padTo n s = s <> T.replicate (n - T.length s) " " diff --git a/src/Draw/Util.hs b/src/Draw/Util.hs --- a/src/Draw/Util.hs +++ b/src/Draw/Util.hs @@ -5,15 +5,18 @@ import Brick import qualified Data.Text as T +import qualified Data.Set as Set import Data.Time.Clock (UTCTime(..)) -import Data.Time.Format (formatTime, defaultTimeLocale) -import Data.Time.LocalTime (TimeZone, utcToLocalTime) +import Data.Time.LocalTime.TimeZone.Series (TimeZoneSeries) import Lens.Micro.Platform -import Network.Mattermost +import Network.Mattermost.Types import Types import Types.Channels +import Types.Messages +import Types.Posts import Types.Users +import TimeUtils import Themes defaultTimeFormat :: T.Text @@ -36,31 +39,46 @@ renderDate :: ChatState -> UTCTime -> Widget Name renderDate st = renderUTCTime (getDateFormat st) (st^.timeZone) -renderUTCTime :: T.Text -> TimeZone -> UTCTime -> Widget a +renderUTCTime :: T.Text -> TimeZoneSeries -> UTCTime -> Widget a renderUTCTime fmt tz t = - let timeStr = T.pack $ formatTime defaultTimeLocale (T.unpack fmt) (utcToLocalTime tz t) - in if T.null fmt - then emptyWidget - else withDefAttr timeAttr (txt timeStr) + if T.null fmt + then emptyWidget + else withDefAttr timeAttr (txt $ localTimeText fmt $ asLocalTime tz t) +-- | Generates a local matterhorn-only client message that creates a +-- date marker. The server date is converted to a local time (via +-- timezone), and midnight of that timezone used to generate date +-- markers. Note that the actual time of the server and this client +-- are still not synchronized, but no manipulations here actually use +-- the client time. +insertDateMarkers :: Messages -> T.Text -> TimeZoneSeries -> Messages +insertDateMarkers ms datefmt tz = foldr (addMessage . dateMsg) ms dateRange + where dateRange = foldr checkDateChange Set.empty ms + checkDateChange m = let msgDay = startOfDay (Just tz) (withServerTime (m^.mDate)) + in if m^.mDeleted then id else Set.insert msgDay + dateMsg d = let t = localTimeText datefmt $ asLocalTime tz d + in newMessageOfType t (C DateTransition) (ServerTime d) + + withBrackets :: Widget a -> Widget a withBrackets w = hBox [str "[", w, str "]"] userSigilFromInfo :: UserInfo -> Char userSigilFromInfo u = case u^.uiStatus of - Offline -> ' ' - Online -> '+' - Away -> '-' - Other _ -> '?' + Offline -> ' ' + Online -> '+' + Away -> '-' + DoNotDisturb -> '×' + Other _ -> '?' mkChannelName :: ChannelInfo -> T.Text -mkChannelName c = T.cons sigil (c^.cdName) +mkChannelName c = T.append sigil (c^.cdName) where sigil = case c^.cdType of - Private -> '?' + Private -> T.singleton '?' Ordinary -> normalChannelSigil Group -> normalChannelSigil Direct -> userSigil - _ -> '!' + _ -> T.singleton '!' mkDMChannelName :: UserInfo -> T.Text mkDMChannelName u = T.cons (userSigilFromInfo u) (u^.uiName) diff --git a/src/Events.hs b/src/Events.hs --- a/src/Events.hs +++ b/src/Events.hs @@ -7,13 +7,16 @@ import Brick import Control.Monad (forM_, when) import Control.Monad.IO.Class (liftIO) +import Data.List (intercalate) +import qualified Data.Map as M import qualified Data.Set as Set import qualified Data.Text as T import Data.Monoid ((<>)) +import GHC.Exts (groupWith) import qualified Graphics.Vty as Vty import Lens.Micro.Platform -import Network.Mattermost +import Network.Mattermost.Types import Network.Mattermost.Lenses import Network.Mattermost.WebSocket @@ -21,7 +24,9 @@ import State import State.Common import Types +import Types.KeyEvents +import Events.Keybindings import Events.ShowHelp import Events.Main import Events.JoinChannel @@ -43,9 +48,7 @@ _ -> return () onAppEvent :: MHEvent -> MH () -onAppEvent RefreshWebsocketEvent = do - st <- use id - liftIO $ connectWebsockets st +onAppEvent RefreshWebsocketEvent = connectWebsockets onAppEvent WebsocketDisconnect = csConnectionStatus .= Disconnected onAppEvent WebsocketConnect = do @@ -139,6 +142,11 @@ removeChannelFromState cId | otherwise -> return () + WMTyping + | Just uId <- wepUserId $ weData we + , Just cId <- webChannelId (weBroadcast we) -> handleTypingUser uId cId + | otherwise -> return () + WMChannelDeleted | Just cId <- wepChannelId (weData we) -> when (webTeamId (weBroadcast we) == Just myTeamId) $ @@ -206,7 +214,113 @@ WMChannelCreated -> return () WMEmojiAdded -> return () WMWebRTC -> return () - WMTyping -> return () WMHello -> return () WMAuthenticationChallenge -> return () WMUserRoleUpdated -> return () + + +-- | Given a configuration, we want to check it for internal +-- consistency (i.e. that a given keybinding isn't associated with +-- multiple events which both need to get generated in the same UI +-- mode) and also for basic usability (i.e. we shouldn't be binding +-- events which can appear in the main UI to a key like @e@, which +-- would prevent us from being able to type messages containing an @e@ +-- in them! +ensureKeybindingConsistency :: KeyConfig -> Either String () +ensureKeybindingConsistency kc = mapM_ checkGroup allBindings + where + -- This is a list of lists, grouped by keybinding, of all the + -- keybinding/event associations that are going to be used with + -- the provided key configuration. + allBindings = groupWith fst $ concat + [ case M.lookup ev kc of + Nothing -> zip (defaultBindings ev) (repeat (False, ev)) + Just (BindingList bs) -> zip bs (repeat (True, ev)) + Just Unbound -> [] + | ev <- allEvents + ] + + -- the invariant here is that each call to checkGroup is made with + -- a list where the first element of every list is the same + -- binding. The Bool value in these is True if the event was + -- associated with the binding by the user, and False if it's a + -- Matterhorn default. + checkGroup :: [(Binding, (Bool, KeyEvent))] -> Either String () + checkGroup [] = error "[ensureKeybindingConsistency: unreachable]" + checkGroup evs@((b, _):_) = do + + -- We find out which modes an event can be used in and then + -- invert the map, so this is a map from mode to the events + -- contains which are bound by the binding included above. + let modesFor :: M.Map String [(Bool, KeyEvent)] + modesFor = M.unionsWith (++) + [ M.fromList [ (m, [(i, ev)]) | m <- modeMap ev ] + | (_, (i, ev)) <- evs + ] + + -- If there is ever a situation where the same key is bound to + -- two events which can appear in the same mode, then we want to + -- throw an error, and also be informative about why. It is + -- still okay to bind the same key to two events, so long as + -- those events never appear in the same UI mode. + forM_ (M.assocs modesFor) $ \ (_, vs) -> + when (length vs > 1) $ + Left $ concat $ + "Multiple overlapping events bound to `" : + T.unpack (ppBinding b) : + "`:\n" : + concat [ [ " - `" + , T.unpack (keyEventName ev) + , "` " + , if isFromUser + then "(via user override)" + else "(matterhorn default)" + , "\n" + ] + | (isFromUser, ev) <- vs + ] + + -- check for overlap a set of built-in keybindings when we're in + -- a mode where the user is typing. (These are perfectly fine + -- when we're in other modes.) + when ("main" `M.member` modesFor && isBareBinding b) $ do + Left $ concat $ + [ "The keybinding `" + , T.unpack (ppBinding b) + , "` is bound to the " + , case map (ppEvent . snd . snd) evs of + [] -> error "unreachable" + [e] -> "event " ++ e + es -> "events " ++ intercalate " and " es + , "\n" + , "This is probably not what you want, as it will interfere\n" + , "with the ability to write messages!\n" + ] + + -- Events get some nice formatting! + ppEvent ev = "`" ++ T.unpack (keyEventName ev) ++ "`" + + -- This check should get more nuanced, but as a first + -- approximation, we shouldn't bind to any bare character key in + -- the main mode. + isBareBinding (Binding [] (Vty.KChar {})) = True + isBareBinding _ = False + + -- We generate the which-events-are-valid-in-which-modes map from + -- our actual keybinding set, so this should never get out of date. + modeMap ev = + let bindingHasEvent (KB _ _ _ (Just ev')) = ev == ev' + bindingHasEvent _ = False + in [ mode + | (mode, bindings) <- modeMaps + , any bindingHasEvent bindings + ] + + modeMaps = [ ("main" :: String, mainKeybindings kc) + , ("help screen", helpKeybindings kc) + , ("channel select", channelSelectKeybindings kc) + , ("url select", urlSelectKeybindings kc) + , ("channel scroll", channelScrollKeybindings kc) + , ("message select", messageSelectKeybindings kc) + , ("post list overlay", postListOverlayKeybindings kc) + ] diff --git a/src/Events/ChannelScroll.hs b/src/Events/ChannelScroll.hs --- a/src/Events/ChannelScroll.hs +++ b/src/Events/ChannelScroll.hs @@ -8,41 +8,38 @@ import Lens.Micro.Platform import Types +import Events.Keybindings import State -channelScrollKeybindings :: [Keybinding] -channelScrollKeybindings = - [ KB "Load more messages in the current channel" - (Vty.EvKey (Vty.KChar 'b') [Vty.MCtrl]) +channelScrollKeybindings :: KeyConfig -> [Keybinding] +channelScrollKeybindings = mkKeybindings + [ mkKb LoadMoreEvent "Load more messages in the current channel" loadMoreMessages - , KB "Select and open a URL posted to the current channel" - (Vty.EvKey (Vty.KChar 'o') [Vty.MCtrl]) + , mkKb EnterOpenURLModeEvent "Select and open a URL posted to the current channel" startUrlSelect - , KB "Scroll up" (Vty.EvKey Vty.KUp []) + , mkKb ScrollUpEvent "Scroll up" channelScrollUp - , KB "Scroll down" (Vty.EvKey Vty.KDown []) + , mkKb ScrollDownEvent "Scroll down" channelScrollDown - , KB "Scroll up" (Vty.EvKey Vty.KPageUp []) + , mkKb PageUpEvent "Scroll up" channelPageUp - , KB "Scroll down" (Vty.EvKey Vty.KPageDown []) + , mkKb PageDownEvent "Scroll down" channelPageDown - , KB "Cancel scrolling and return to channel view" - (Vty.EvKey Vty.KEsc []) $ + , mkKb CancelEvent "Cancel scrolling and return to channel view" $ csMode .= Main - , KB "Scroll to top" (Vty.EvKey Vty.KHome []) + , mkKb ScrollTopEvent "Scroll to top" channelScrollToTop - , KB "Scroll to bottom" (Vty.EvKey Vty.KEnd []) + , mkKb ScrollBottomEvent "Scroll to bottom" channelScrollToBottom ] onEventChannelScroll :: Vty.Event -> MH () -onEventChannelScroll (Vty.EvResize _ _) = do - cId <- use csCurrentChannelId - mh $ do - invalidateCache - let vp = ChannelMessages cId - vScrollToEnd $ viewportScroll vp -onEventChannelScroll e - | Just kb <- lookupKeybinding e channelScrollKeybindings = kbAction kb -onEventChannelScroll _ = do - return () +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/ChannelSelect.hs b/src/Events/ChannelSelect.hs --- a/src/Events/ChannelSelect.hs +++ b/src/Events/ChannelSelect.hs @@ -8,23 +8,24 @@ import qualified Graphics.Vty as Vty import Lens.Micro.Platform +import Events.Keybindings import Types import State onEventChannelSelect :: Vty.Event -> MH () -onEventChannelSelect e | Just kb <- lookupKeybinding e channelSelectKeybindings = - kbAction kb -onEventChannelSelect (Vty.EvKey Vty.KBS []) = do - csChannelSelectState.channelSelectInput %= (\s -> if T.null s then s else T.init s) - updateChannelSelectMatches -onEventChannelSelect (Vty.EvKey (Vty.KChar c) []) | c /= '\t' = do - csChannelSelectState.channelSelectInput %= (flip T.snoc c) - updateChannelSelectMatches -onEventChannelSelect _ = return () +onEventChannelSelect = + handleKeyboardEvent channelSelectKeybindings $ \ e -> case e of + (Vty.EvKey Vty.KBS []) -> do + csChannelSelectState.channelSelectInput %= (\s -> if T.null s then s else T.init s) + updateChannelSelectMatches + (Vty.EvKey (Vty.KChar c) []) | c /= '\t' -> do + csChannelSelectState.channelSelectInput %= (flip T.snoc c) + updateChannelSelectMatches + _ -> return () -channelSelectKeybindings :: [Keybinding] -channelSelectKeybindings = - [ KB "Switch to selected channel" +channelSelectKeybindings :: KeyConfig -> [Keybinding] +channelSelectKeybindings = mkKeybindings + [ staticKb "Switch to selected channel" (Vty.EvKey Vty.KEnter []) $ do selMatch <- use (csChannelSelectState.selectedMatch) @@ -32,19 +33,7 @@ when (selMatch /= "") $ do changeChannel selMatch - , KB "Cancel channel selection" - (Vty.EvKey Vty.KEsc []) $ do - csMode .= Main - - , KB "Cancel channel selection" - (Vty.EvKey (Vty.KChar 'c') [Vty.MCtrl]) $ do - csMode .= Main - - , KB "Select next match" - (Vty.EvKey (Vty.KChar 'n') [Vty.MCtrl]) $ do - channelSelectNext - - , KB "Select previous match" - (Vty.EvKey (Vty.KChar 'p') [Vty.MCtrl]) $ do - channelSelectPrevious + , mkKb CancelEvent "Cancel channel selection" $ csMode .= Main + , mkKb NextChannelEvent "Select next match" channelSelectNext + , mkKb PrevChannelEvent "Select previous match" channelSelectPrevious ] diff --git a/src/Events/Keybindings.hs b/src/Events/Keybindings.hs new file mode 100644 --- /dev/null +++ b/src/Events/Keybindings.hs @@ -0,0 +1,123 @@ +module Events.Keybindings + ( defaultBindings + , lookupKeybinding + + , mkKb + , staticKb + , mkKeybindings + + , handleKeyboardEvent + + -- Re-exports: + , Keybinding (..) + , KeyEvent (..) + , KeyConfig + , allEvents + , parseBinding + , keyEventName + , keyEventFromName + ) where + +import qualified Data.Map.Strict as M +import qualified Data.Text as T +import qualified Graphics.Vty as Vty +import Lens.Micro.Platform (use) + +import Types +import Types.KeyEvents + +-- * Keybindings + +-- | A 'Keybinding' represents a keybinding along with its +-- implementation +data Keybinding = + KB { kbDescription :: T.Text + , kbEvent :: Vty.Event + , kbAction :: MH () + , kbBindingInfo :: Maybe KeyEvent + } + +-- | Find a keybinding that matches a Vty Event +lookupKeybinding :: Vty.Event -> [Keybinding] -> Maybe Keybinding +lookupKeybinding e kbs = case filter ((== e) . kbEvent) kbs of + [] -> Nothing + (x:_) -> Just x + +handleKeyboardEvent + :: (KeyConfig -> [Keybinding]) + -> (Vty.Event -> MH ()) + -> Vty.Event + -> MH () +handleKeyboardEvent keyList fallthrough e = do + conf <- use (csResources.crConfiguration) + let keyMap = keyList (configUserKeys conf) + case lookupKeybinding e keyMap of + Just kb -> kbAction kb + Nothing -> fallthrough e + +mkKb :: KeyEvent -> T.Text -> MH () -> KeyConfig -> [Keybinding] +mkKb ev msg action conf = + [ KB msg (bindingToEvent key) action (Just ev) | key <- allKeys ] + where allKeys | Just (BindingList ks) <- M.lookup ev conf = ks + | Just Unbound <- M.lookup ev conf = [] + | otherwise = defaultBindings ev + +staticKb :: T.Text -> Vty.Event -> MH () -> KeyConfig -> [Keybinding] +staticKb msg event action _ = [KB msg event action Nothing] + +mkKeybindings :: [KeyConfig -> [Keybinding]] -> KeyConfig -> [Keybinding] +mkKeybindings ks conf = concat [ k conf | k <- ks ] + +bindingToEvent :: Binding -> Vty.Event +bindingToEvent binding = + Vty.EvKey (kbKey binding) (kbMods binding) + +defaultBindings :: KeyEvent -> [Binding] +defaultBindings ev = + let meta binding = binding { kbMods = Vty.MMeta : kbMods binding } + ctrl binding = binding { kbMods = Vty.MCtrl : kbMods binding } + kb k = Binding { kbMods = [], kbKey = k } + key c = Binding { kbMods = [], kbKey = Vty.KChar c } + fn n = Binding { kbMods = [], kbKey = Vty.KFun n } + in case ev of + VtyRefreshEvent -> [ ctrl (key 'l') ] + ShowHelpEvent -> [ fn 1 ] + EnterSelectModeEvent -> [ ctrl (key 's') ] + ReplyRecentEvent -> [ ctrl (key 'r') ] + ToggleMessagePreviewEvent -> [ meta (key 'p') ] + InvokeEditorEvent -> [ meta (key 'k') ] + EnterFastSelectModeEvent -> [ ctrl (key 'g') ] + QuitEvent -> [ ctrl (key 'q') ] + NextChannelEvent -> [ ctrl (key 'n') ] + PrevChannelEvent -> [ ctrl (key 'p') ] + NextUnreadChannelEvent -> [ meta (key 'a') ] + LastChannelEvent -> [ meta (key 's') ] + EnterOpenURLModeEvent -> [ ctrl (key 'o') ] + ClearUnreadEvent -> [ meta (key 'l') ] + ToggleMultiLineEvent -> [ meta (key 'e') ] + EnterFlaggedPostsEvent -> [ meta (key '8') ] + + CancelEvent -> [ kb Vty.KEsc + , ctrl (key 'c') + ] + + -- channel-scroll-specific + LoadMoreEvent -> [ ctrl (key 'b') ] + + -- scrolling events + ScrollUpEvent -> [ kb Vty.KUp ] + ScrollDownEvent -> [ kb Vty.KDown ] + PageUpEvent -> [ kb Vty.KPageUp ] + PageDownEvent -> [ kb Vty.KPageDown ] + ScrollTopEvent -> [ kb Vty.KHome ] + ScrollBottomEvent -> [ kb Vty.KEnd ] + + SelectUpEvent -> [ key 'k', kb Vty.KUp ] + SelectDownEvent -> [ key 'j', kb Vty.KDown ] + + FlagMessageEvent -> [ key 'f' ] + YankMessageEvent -> [ key 'y' ] + DeleteMessageEvent -> [ key 'd' ] + EditMessageEvent -> [ key 'e' ] + ReplyMessageEvent -> [ key 'r' ] + OpenMessageURLEvent -> [ key 'o' ] diff --git a/src/Events/Main.hs b/src/Events/Main.hs --- a/src/Events/Main.hs +++ b/src/Events/Main.hs @@ -18,6 +18,7 @@ import Types import Types.Channels (ccInfo, cdType, clearNewMessageIndicator, clearEditedThreshold) import Types.Users (uiDeleted, findUserById) +import Events.Keybindings import State import State.PostListOverlay (enterFlaggedPostListMode) import State.Editing @@ -27,52 +28,63 @@ import HelpTopics (mainHelpTopic) import Constants -import Network.Mattermost (Type(..)) +import Network.Mattermost.Types (Type(..)) onEventMain :: Vty.Event -> MH () -onEventMain e | Just kb <- lookupKeybinding e mainKeybindings = kbAction kb -onEventMain (Vty.EvPaste bytes) = handlePaste bytes -onEventMain e = handleEditingInput e +onEventMain = + handleKeyboardEvent mainKeybindings $ \ ev -> case ev of + (Vty.EvPaste bytes) -> handlePaste bytes + _ -> handleEditingInput ev + -- conf <- use (csResources.crConfiguration) + -- let keyMap = mainKeybindings (configUserKeys conf) + -- case e of + -- _ | Just kb <- lookupKeybinding e keyMap -> kbAction kb + -- (Vty.EvPaste bytes) -> handlePaste bytes + -- _ -> handleEditingInput e -mainKeybindings :: [Keybinding] -mainKeybindings = - [ KB "Show this help screen" - (Vty.EvKey (Vty.KFun 1) []) $ - showHelpScreen mainHelpTopic +mainKeybindings :: KeyConfig -> [Keybinding] +mainKeybindings = mkKeybindings + [ mkKb ShowHelpEvent + "Show this help screen" + (showHelpScreen mainHelpTopic) - , KB "Select a message to edit/reply/delete" - (Vty.EvKey (Vty.KChar 's') [Vty.MCtrl]) $ - beginMessageSelect + , mkKb EnterSelectModeEvent + "Select a message to edit/reply/delete" + beginMessageSelect - , KB "Reply to the most recent message" - (Vty.EvKey (Vty.KChar 'r') [Vty.MCtrl]) $ - replyToLatestMessage + , mkKb ReplyRecentEvent + "Reply to the most recent message" + replyToLatestMessage - , KB "Toggle message preview" - (Vty.EvKey (Vty.KChar 'p') [Vty.MMeta]) $ - toggleMessagePreview + , mkKb ToggleMessagePreviewEvent "Toggle message preview" + toggleMessagePreview - , KB "Invoke *$EDITOR* to edit the current message" - (Vty.EvKey (Vty.KChar 'k') [Vty.MMeta]) $ - invokeExternalEditor + , mkKb + InvokeEditorEvent + "Invoke *$EDITOR* to edit the current message" + invokeExternalEditor - , KB "Enter fast channel selection mode" - (Vty.EvKey (Vty.KChar 'g') [Vty.MCtrl]) $ + , mkKb + EnterFastSelectModeEvent + "Enter fast channel selection mode" beginChannelSelect - , KB "Quit" - (Vty.EvKey (Vty.KChar 'q') [Vty.MCtrl]) $ requestQuit + , mkKb + QuitEvent + "Quit" + requestQuit - , KB "Tab-complete forward" + , staticKb "Tab-complete forward" (Vty.EvKey (Vty.KChar '\t') []) $ tabComplete Forwards - , KB "Tab-complete backward" + , staticKb "Tab-complete backward" (Vty.EvKey (Vty.KBackTab) []) $ tabComplete Backwards - , KB "Scroll up in the channel input history" - (Vty.EvKey Vty.KUp []) $ do + , mkKb + ScrollUpEvent + "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) @@ -81,8 +93,9 @@ (Vty.EvKey Vty.KUp []) False -> channelHistoryBackward - , KB "Scroll down in the channel input history" - (Vty.EvKey Vty.KDown []) $ do + , mkKb + ScrollDownEvent + "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) @@ -91,8 +104,7 @@ (Vty.EvKey Vty.KDown []) False -> channelHistoryForward - , KB "Page up in the channel message list" - (Vty.EvKey Vty.KPageUp []) $ do + , mkKb PageUpEvent "Page up in the channel message list" $ do cId <- use csCurrentChannelId let vp = ChannelMessages cId mh $ invalidateCacheEntry vp @@ -100,23 +112,19 @@ mh $ vScrollBy (viewportScroll vp) (-1 * pageAmount) csMode .= ChannelScroll - , KB "Change to the next channel in the channel list" - (Vty.EvKey (Vty.KChar 'n') [Vty.MCtrl]) $ + , mkKb NextChannelEvent "Change to the next channel in the channel list" nextChannel - , KB "Change to the previous channel in the channel list" - (Vty.EvKey (Vty.KChar 'p') [Vty.MCtrl]) $ + , mkKb PrevChannelEvent "Change to the previous channel in the channel list" prevChannel - , KB "Change to the next channel with unread messages" - (Vty.EvKey (Vty.KChar 'a') [Vty.MMeta]) $ + , mkKb NextUnreadChannelEvent "Change to the next channel with unread messages" nextUnreadChannel - , KB "Change to the most recently-focused channel" - (Vty.EvKey (Vty.KChar 's') [Vty.MMeta]) $ + , mkKb LastChannelEvent "Change to the most recently-focused channel" recentChannel - , KB "Send the current message" + , staticKb "Send the current message" (Vty.EvKey Vty.KEnter []) $ do isMultiline <- use (csEditState.cedMultiline) case isMultiline of @@ -129,29 +137,20 @@ csEditState.cedCurrentCompletion .= Nothing handleInputSubmission - , KB "Select and open a URL posted to the current channel" - (Vty.EvKey (Vty.KChar 'o') [Vty.MCtrl]) $ + , mkKb EnterOpenURLModeEvent "Select and open a URL posted to the current channel" startUrlSelect - , KB "Clear the current channel's unread / edited indicators" - (Vty.EvKey (Vty.KChar 'l') [Vty.MMeta]) $ + , mkKb ClearUnreadEvent "Clear the current channel's unread / edited indicators" $ csCurrentChannel %= (clearNewMessageIndicator . clearEditedThreshold) - , KB "Toggle multi-line message compose mode" - (Vty.EvKey (Vty.KChar 'e') [Vty.MMeta]) $ + , mkKb ToggleMultiLineEvent "Toggle multi-line message compose mode" toggleMultilineEditing - , KB "Cancel message reply or update" - (Vty.EvKey Vty.KEsc []) $ - cancelReplyOrEdit - - , KB "Cancel message reply or update" - (Vty.EvKey (Vty.KChar 'c') [Vty.MCtrl]) $ + , mkKb CancelEvent "Cancel message reply or update" cancelReplyOrEdit - , KB "View currently flagged posts" - (Vty.EvKey (Vty.KChar '8') [Vty.MMeta]) $ + , mkKb EnterFlaggedPostsEvent "View currently flagged posts" enterFlaggedPostListMode ] @@ -208,8 +207,8 @@ priorities = [] :: [T.Text]-- XXX: add recent completions to this completions = Set.fromList (completableUsers ++ completableChannels ++ - map (T.singleton userSigil <>) completableUsers ++ - map (T.singleton normalChannelSigil <>) completableChannels ++ + map (userSigil <>) completableUsers ++ + map (normalChannelSigil <>) completableChannels ++ map ("/" <>) (commandName <$> commandList)) line = Z.currentLine $ st^.csEditState.cedEditor.editContentsL diff --git a/src/Events/MessageSelect.hs b/src/Events/MessageSelect.hs --- a/src/Events/MessageSelect.hs +++ b/src/Events/MessageSelect.hs @@ -9,15 +9,15 @@ import Lens.Micro.Platform import Types +import Events.Keybindings import State messagesPerPageOperation :: Int messagesPerPageOperation = 10 onEventMessageSelect :: Vty.Event -> MH () -onEventMessageSelect e | Just kb <- lookupKeybinding e messageSelectKeybindings = - kbAction kb -onEventMessageSelect _ = return () +onEventMessageSelect = + handleKeyboardEvent messageSelectKeybindings $ \ _ -> return () onEventMessageSelectDeleteConfirm :: Vty.Event -> MH () onEventMessageSelectDeleteConfirm (Vty.EvKey (Vty.KChar 'y') []) = do @@ -26,61 +26,38 @@ onEventMessageSelectDeleteConfirm _ = csMode .= Main -messageSelectKeybindings :: [Keybinding] -messageSelectKeybindings = - [ KB "Cancel message selection" - (Vty.EvKey Vty.KEsc []) $ csMode .= Main - - , KB "Cancel message selection" - (Vty.EvKey (Vty.KChar 'c') [Vty.MCtrl]) $ - csMode .= Main - - , KB "Select the previous message" - (Vty.EvKey (Vty.KChar 'k') []) $ - messageSelectUp - - , KB "Select the previous message" - (Vty.EvKey Vty.KUp []) $ - messageSelectUp - - , KB (T.pack $ "Move the cursor up by " <> show messagesPerPageOperation <> " messages") - (Vty.EvKey Vty.KPageUp []) $ - messageSelectUpBy messagesPerPageOperation - - , KB "Select the next message" - (Vty.EvKey (Vty.KChar 'j') []) $ - messageSelectDown - - , KB "Select the next message" - (Vty.EvKey Vty.KDown []) $ - messageSelectDown +messageSelectKeybindings :: KeyConfig -> [Keybinding] +messageSelectKeybindings = mkKeybindings + [ mkKb CancelEvent "Cancel message selection" $ + csMode .= Main - , KB (T.pack $ "Move the cursor down by " <> show messagesPerPageOperation <> " messages") - (Vty.EvKey Vty.KPageDown []) $ - messageSelectDownBy messagesPerPageOperation + , mkKb SelectUpEvent "Select the previous message" messageSelectUp + , mkKb SelectDownEvent "Select the next message" messageSelectDown + , mkKb + PageUpEvent + (T.pack $ "Move the cursor up by " <> show messagesPerPageOperation <> " messages") + (messageSelectUpBy messagesPerPageOperation) + , mkKb + PageDownEvent + (T.pack $ "Move the cursor down by " <> show messagesPerPageOperation <> " messages") + (messageSelectDownBy messagesPerPageOperation) - , KB "Open all URLs in the selected message" - (Vty.EvKey (Vty.KChar 'o') []) $ - openSelectedMessageURLs + , mkKb OpenMessageURLEvent "Open all URLs in the selected message" + openSelectedMessageURLs - , KB "Begin composing a reply to the selected message" - (Vty.EvKey (Vty.KChar 'r') []) $ + , mkKb ReplyMessageEvent "Begin composing a reply to the selected message" beginReplyCompose - , KB "Begin editing the selected message" - (Vty.EvKey (Vty.KChar 'e') []) $ + , mkKb EditMessageEvent "Begin editing the selected message" beginUpdateMessage - , KB "Delete the selected message (with confirmation)" - (Vty.EvKey (Vty.KChar 'd') []) $ + , mkKb DeleteMessageEvent "Delete the selected message (with confirmation)" beginConfirmDeleteSelectedMessage - , KB "Copy a verbatim section to the clipboard" - (Vty.EvKey (Vty.KChar 'y') []) $ + , mkKb YankMessageEvent "Copy a verbatim section to the clipboard" copyVerbatimToClipboard - , KB "Flag the selected message" - (Vty.EvKey (Vty.KChar 'f') []) $ + , mkKb FlagMessageEvent "Flag the selected message" flagSelectedMessage ] diff --git a/src/Events/PostListOverlay.hs b/src/Events/PostListOverlay.hs --- a/src/Events/PostListOverlay.hs +++ b/src/Events/PostListOverlay.hs @@ -3,35 +3,18 @@ import qualified Graphics.Vty as Vty import Types +import Events.Keybindings import State.PostListOverlay onEventPostListOverlay :: Vty.Event -> MH () -onEventPostListOverlay e - | Just kb <- lookupKeybinding e postListOverlayKeybindings = - kbAction kb -onEventPostListOverlay _ = return () +onEventPostListOverlay = + handleKeyboardEvent postListOverlayKeybindings $ \ _ -> return () -- | The keybindings we want to use while viewing a post list overlay -postListOverlayKeybindings :: [Keybinding] -postListOverlayKeybindings = - [ KB "Exit post browsing" (Vty.EvKey Vty.KEsc []) $ - exitPostListMode - - , KB "Exit post browsing" (Vty.EvKey (Vty.KChar 'c') [Vty.MCtrl]) $ - exitPostListMode - - , KB "Select the previous message" (Vty.EvKey (Vty.KChar 'k') []) $ - postListSelectUp - - , KB "Select the previous message" (Vty.EvKey Vty.KUp []) $ - postListSelectUp - - , KB "Select the next message" (Vty.EvKey (Vty.KChar 'j') []) $ - postListSelectDown - - , KB "Select the next message" (Vty.EvKey Vty.KDown []) $ - postListSelectDown - - , KB "Toggle the selected message flag" (Vty.EvKey (Vty.KChar 'f') []) $ - postListUnflagSelected +postListOverlayKeybindings :: KeyConfig -> [Keybinding] +postListOverlayKeybindings = mkKeybindings + [ mkKb CancelEvent "Exit post browsing" exitPostListMode + , mkKb SelectUpEvent "Select the previous message" postListSelectUp + , mkKb SelectDownEvent "Select the next message" postListSelectDown + , mkKb FlagMessageEvent "Toggle the selected message flag" postListUnflagSelected ] diff --git a/src/Events/ShowHelp.hs b/src/Events/ShowHelp.hs --- a/src/Events/ShowHelp.hs +++ b/src/Events/ShowHelp.hs @@ -8,33 +8,45 @@ import Lens.Micro.Platform import Types +import Events.Keybindings import Constants onEventShowHelp :: Vty.Event -> MH () -onEventShowHelp e | Just kb <- lookupKeybinding e helpKeybindings = - kbAction kb -onEventShowHelp (Vty.EvKey _ _) = do - csMode .= Main -onEventShowHelp _ = return () +onEventShowHelp = + handleKeyboardEvent helpKeybindings $ \ e -> case e of + Vty.EvKey _ _ -> csMode .= Main + _ -> return () -helpKeybindings :: [Keybinding] -helpKeybindings = - [ KB "Scroll up" - (Vty.EvKey Vty.KUp []) $ do - mh $ vScrollBy (viewportScroll HelpViewport) (-1) - , KB "Scroll down" - (Vty.EvKey Vty.KDown []) $ do - mh $ vScrollBy (viewportScroll HelpViewport) 1 - , KB "Page up" - (Vty.EvKey Vty.KPageUp []) $ do - mh $ vScrollBy (viewportScroll HelpViewport) (-1 * pageAmount) - , KB "Page down" - (Vty.EvKey Vty.KPageDown []) $ do - mh $ vScrollBy (viewportScroll HelpViewport) pageAmount - , KB "Page down" - (Vty.EvKey (Vty.KChar ' ') []) $ do - mh $ vScrollBy (viewportScroll HelpViewport) pageAmount - , KB "Return to the main interface" - (Vty.EvKey Vty.KEsc []) $ do - csMode .= Main +helpKeybindings :: KeyConfig -> [Keybinding] +helpKeybindings = mkKeybindings + [ mkKb ScrollUpEvent "Scroll up" $ + mh $ vScrollBy (viewportScroll HelpViewport) (-1) + , mkKb ScrollDownEvent "Scroll down" $ + mh $ vScrollBy (viewportScroll HelpViewport) 1 + , mkKb PageUpEvent "Page up" $ + mh $ vScrollBy (viewportScroll HelpViewport) (-1 * pageAmount) + , mkKb PageDownEvent "Page down" $ + mh $ vScrollBy (viewportScroll HelpViewport) (1 * pageAmount) + , mkKb CancelEvent "Return to the main interface" $ + csMode .= Main ] + +-- KB "Scroll up" +-- (Vty.EvKey Vty.KUp []) $ do +-- mh $ vScrollBy (viewportScroll HelpViewport) (-1) +-- , KB "Scroll down" +-- (Vty.EvKey Vty.KDown []) $ do +-- mh $ vScrollBy (viewportScroll HelpViewport) 1 +-- , KB "Page up" +-- (Vty.EvKey Vty.KPageUp []) $ do +-- mh $ vScrollBy (viewportScroll HelpViewport) (-1 * pageAmount) +-- , KB "Page down" +-- (Vty.EvKey Vty.KPageDown []) $ do +-- mh $ vScrollBy (viewportScroll HelpViewport) pageAmount +-- , KB "Page down" +-- (Vty.EvKey (Vty.KChar ' ') []) $ do +-- mh $ vScrollBy (viewportScroll HelpViewport) pageAmount +-- , KB "Return to the main interface" +-- (Vty.EvKey Vty.KEsc []) $ do +-- csMode .= Main +-- ] diff --git a/src/Events/UrlSelect.hs b/src/Events/UrlSelect.hs --- a/src/Events/UrlSelect.hs +++ b/src/Events/UrlSelect.hs @@ -8,32 +8,30 @@ import Lens.Micro.Platform import Types +import Events.Keybindings import State onEventUrlSelect :: Vty.Event -> MH () -onEventUrlSelect e - | Just kb <- lookupKeybinding e urlSelectKeybindings = kbAction kb - | otherwise = mhHandleEventLensed csUrlList handleListEvent e +onEventUrlSelect = + handleKeyboardEvent urlSelectKeybindings $ \ ev -> + mhHandleEventLensed csUrlList handleListEvent ev -urlSelectKeybindings :: [Keybinding] -urlSelectKeybindings = - [ KB "Open the selected URL, if any" +urlSelectKeybindings :: KeyConfig -> [Keybinding] +urlSelectKeybindings = mkKeybindings + [ staticKb "Open the selected URL, if any" (Vty.EvKey Vty.KEnter []) $ do openSelectedURL csMode .= Main - , KB "Cancel URL selection" - (Vty.EvKey Vty.KEsc []) $ stopUrlSelect + , mkKb CancelEvent "Cancel URL selection" stopUrlSelect - , KB "Cancel URL selection" - (Vty.EvKey (Vty.KChar 'q') []) $ stopUrlSelect + , mkKb SelectUpEvent "Move cursor up" $ + mhHandleEventLensed csUrlList handleListEvent (Vty.EvKey Vty.KUp []) - , KB "Move cursor down" - (Vty.EvKey (Vty.KChar 'j') []) $ - mhHandleEventLensed csUrlList handleListEvent (Vty.EvKey Vty.KDown []) + , mkKb SelectDownEvent "Move cursor down" $ + mhHandleEventLensed csUrlList handleListEvent (Vty.EvKey Vty.KDown []) - , KB "Move cursor up" - (Vty.EvKey (Vty.KChar 'k') []) $ - mhHandleEventLensed csUrlList handleListEvent (Vty.EvKey Vty.KUp []) + , staticKb "Cancel URL selection" + (Vty.EvKey (Vty.KChar 'q') []) $ stopUrlSelect ] diff --git a/src/FilePaths.hs b/src/FilePaths.hs --- a/src/FilePaths.hs +++ b/src/FilePaths.hs @@ -3,6 +3,9 @@ ( historyFilePath , historyFileName + , lastRunStateFilePath + , lastRunStateFileName + , configFileName , xdgName @@ -19,6 +22,7 @@ import Control.Monad (forM, filterM) import Data.Monoid ((<>)) import Data.Maybe (listToMaybe) +import Data.Text (unpack, Text) import System.Directory ( doesFileExist , doesDirectoryExist , getDirectoryContents @@ -34,11 +38,18 @@ historyFileName :: FilePath historyFileName = "history.txt" +lastRunStateFileName :: Text -> FilePath +lastRunStateFileName teamId = "last_run_state_" ++ unpack teamId ++ ".json" + configFileName :: FilePath configFileName = "config.ini" historyFilePath :: IO FilePath historyFilePath = getUserConfigFile xdgName historyFileName + +lastRunStateFilePath :: Text -> IO FilePath +lastRunStateFilePath teamId = + getUserConfigFile xdgName (lastRunStateFileName teamId) -- | Find a specified configuration file by looking in all of the -- supported locations. diff --git a/src/HelpTopics.hs b/src/HelpTopics.hs --- a/src/HelpTopics.hs +++ b/src/HelpTopics.hs @@ -21,6 +21,7 @@ [ mainHelpTopic , scriptHelpTopic , themeHelpTopic + , keybindingHelpTopic ] mainHelpTopic :: HelpTopic @@ -34,6 +35,11 @@ themeHelpTopic :: HelpTopic themeHelpTopic = HelpTopic "themes" "Help on color themes" ThemeHelp ThemeHelpText + +keybindingHelpTopic :: HelpTopic +keybindingHelpTopic = + HelpTopic "keybindings" "Help on overriding keybindings" + KeybindingHelp KeybindingHelpText lookupHelpTopic :: T.Text -> Maybe HelpTopic lookupHelpTopic topic = diff --git a/src/InputHistory.hs b/src/InputHistory.hs --- a/src/InputHistory.hs +++ b/src/InputHistory.hs @@ -25,7 +25,7 @@ import IOUtil import FilePaths -import Network.Mattermost (ChannelId) +import Network.Mattermost.Types (ChannelId) data InputHistory = InputHistory { _historyEntries :: HM.HashMap ChannelId (V.Vector Text) diff --git a/src/LastRunState.hs b/src/LastRunState.hs new file mode 100644 --- /dev/null +++ b/src/LastRunState.hs @@ -0,0 +1,97 @@ +{-# LANGUAGE TemplateHaskell #-} +module LastRunState + ( LastRunState + , lrsHost + , lrsPort + , lrsUserId + , lrsSelectedChannelId + , writeLastRunState + , readLastRunState + , isValidLastRunState + ) where + +import Prelude () +import Prelude.Compat + +import Control.Monad (when) +import Control.Monad.Trans.Except +import qualified Data.Aeson as A +import qualified Data.ByteString as BS +import qualified Data.ByteString.Lazy as LBS +import Lens.Micro.Platform +import System.Directory (createDirectoryIfMissing) +import System.FilePath (dropFileName) +import qualified System.Posix.Files as P +import qualified System.Posix.Types as P + +import IOUtil +import FilePaths +import Network.Mattermost.Types +import Network.Mattermost.Lenses +import Types +import Types.Channels + +-- | Run state of the program. This is saved in a file on program exit and +-- | looked up from the file on program startup. +data LastRunState = LastRunState + { _lrsHost :: Hostname -- ^ Host of the server + , _lrsPort :: Port -- ^ Post of the server + , _lrsUserId :: UserId -- ^ ID of the logged-in user + , _lrsSelectedChannelId :: ChannelId -- ^ ID of the last selected channel + } + +instance A.ToJSON LastRunState where + toJSON lrs = A.object [ "host" A..= _lrsHost lrs + , "port" A..= _lrsPort lrs + , "user_id" A..= _lrsUserId lrs + , "sel_channel_id" A..= _lrsSelectedChannelId lrs + ] + +instance A.FromJSON LastRunState where + parseJSON = A.withObject "LastRunState" $ \v -> + LastRunState + <$> v A..: "host" + <*> v A..: "port" + <*> v A..: "user_id" + <*> v A..: "sel_channel_id" + +makeLenses ''LastRunState + +toLastRunState :: ChatState -> LastRunState +toLastRunState cs = LastRunState + { _lrsHost = cs^.csResources.crConn.cdHostnameL + , _lrsPort = cs^.csResources.crConn.cdPortL + , _lrsUserId = cs^.csMe.userIdL + , _lrsSelectedChannelId = cs^.csCurrentChannelId + } + +lastRunStateFileMode :: P.FileMode +lastRunStateFileMode = P.unionFileModes P.ownerReadMode P.ownerWriteMode + +-- | Writes the run state to a file. The file is specific to the current team. +-- | Writes only if the current channel is an ordrinary or a private channel. +writeLastRunState :: ChatState -> IO (Either String ()) +writeLastRunState cs = runExceptT . convertIOException $ + when (cs^.csCurrentChannel.ccInfo.cdType `elem` [Ordinary, Private]) $ do + let runState = toLastRunState cs + tId = cs^.csMyTeam.teamIdL + lastRunStateFile <- lastRunStateFilePath $ unId $ toId tId + createDirectoryIfMissing True $ dropFileName lastRunStateFile + BS.writeFile lastRunStateFile $ LBS.toStrict $ A.encode runState + P.setFileMode lastRunStateFile lastRunStateFileMode + +-- | Reads the last run state from a file given the current team ID. +readLastRunState :: TeamId -> IO (Either String LastRunState) +readLastRunState tId = runExceptT $ do + contents <- convertIOException $ + lastRunStateFilePath (unId $ toId tId) >>= BS.readFile + case A.eitherDecodeStrict' contents of + Right val -> return val + Left err -> throwE $ "Failed to parse lastRunState file: " ++ err + +-- | Checks if the given last run state is valid for the current server and user. +isValidLastRunState :: ChatResources -> User -> LastRunState -> Bool +isValidLastRunState cr myUser rs = + rs^.lrsHost == cr^.crConn.cdHostnameL + && rs^.lrsPort == cr^.crConn.cdPortL + && rs^.lrsUserId == myUser^.userIdL diff --git a/src/Login.hs b/src/Login.hs --- a/src/Login.hs +++ b/src/Login.hs @@ -9,82 +9,64 @@ import Prelude.Compat import Brick +import Brick.Forms +import Brick.Focus import Brick.Widgets.Edit import Brick.Widgets.Center import Brick.Widgets.Border import Control.Monad.IO.Class (liftIO) -import Data.Char (isNumber) -import Data.Maybe (isNothing) import Data.Monoid ((<>)) -import Text.Read (readMaybe) import Lens.Micro.Platform import qualified Data.Text as T -import Graphics.Vty hiding (Config) +import Graphics.Vty import System.Exit (exitSuccess) import Network.Mattermost.Exceptions (LoginFailureException(..)) -import Config import Markdown -import Types (ConnectionInfo(..), AuthenticationException(..)) +import Types ( ConnectionInfo(..), ciPassword, ciUsername, ciHostname + , ciPort, AuthenticationException(..) + ) data Name = Hostname | Port | Username | Password deriving (Ord, Eq, Show) data State = - State { _hostnameEdit :: Editor T.Text Name - , _portEdit :: Editor T.Text Name - , _usernameEdit :: Editor T.Text Name - , _passwordEdit :: Editor T.Text Name - , _focus :: Name + State { _loginForm :: Form ConnectionInfo () Name , _previousError :: Maybe AuthenticationException } makeLenses ''State -toPassword :: [T.Text] -> Widget a -toPassword s = txt $ T.replicate (T.length $ T.concat s) "*" - -validHostname :: State -> Bool -validHostname st = - all (flip notElem (":/"::String)) $ T.unpack $ T.concat $ getEditContents $ st^.hostnameEdit - -validPort :: State -> Bool -validPort st = - all isNumber $ T.unpack $ T.concat $ getEditContents $ st^.portEdit +validHostname :: [T.Text] -> Maybe T.Text +validHostname ls = + let s = T.unpack t + t = T.concat ls + in if all (flip notElem (":/"::String)) s + then Just t + else Nothing -interactiveGatherCredentials :: Config +interactiveGatherCredentials :: ConnectionInfo -> Maybe AuthenticationException -> IO ConnectionInfo interactiveGatherCredentials config authError = do let state = newState config authError finalSt <- defaultMain app state - let finalH = T.concat $ getEditContents $ finalSt^.hostnameEdit - finalPort = read $ T.unpack $ T.concat $ getEditContents $ finalSt^.portEdit - finalU = T.concat $ getEditContents $ finalSt^.usernameEdit - finalPass = T.concat $ getEditContents $ finalSt^.passwordEdit - return $ ConnectionInfo finalH finalPort finalU finalPass + return $ formState $ finalSt^.loginForm -newState :: Config -> Maybe AuthenticationException -> State -newState config authError = state +newState :: ConnectionInfo -> Maybe AuthenticationException -> State +newState cInfo authError = state where - state = State { _hostnameEdit = editor Hostname (Just 1) hStr - , _portEdit = editor Port (Just 1) (T.pack $ show $ configPort config) - , _usernameEdit = editor Username (Just 1) uStr - , _passwordEdit = editor Password (Just 1) pStr - , _focus = initialFocus + state = State { _loginForm = form { formFocus = focusSetCurrent initialFocus (formFocus form) + } , _previousError = authError } - hStr = maybe "" id $ configHost config - uStr = maybe "" id $ configUser config - pStr = case configPass config of - Just (PasswordString s) -> s - _ -> "" - initialFocus = if | T.null hStr -> Hostname - | T.null uStr -> Username - | T.null pStr -> Password - | otherwise -> Hostname + form = mkForm cInfo + initialFocus = if | T.null (cInfo^.ciHostname) -> Hostname + | T.null (cInfo^.ciUsername) -> Username + | T.null (cInfo^.ciPassword) -> Password + | otherwise -> Hostname -app :: App State e Name +app :: App State () Name app = App { appDraw = credsDraw , appChooseCursor = showFirstCursor @@ -93,6 +75,28 @@ , appAttrMap = const colorTheme } +editHostname :: (Show n, Ord n) => Lens' s T.Text -> n -> s -> FormFieldState s e n +editHostname stLens n = + let ini = id + val = validHostname + limit = Just 1 + renderTxt = txt . T.unlines + in editField stLens n limit ini val renderTxt id + +mkForm :: ConnectionInfo -> Form ConnectionInfo e Name +mkForm = + let label s w = padBottom (Pad 1) $ + (vLimit 1 $ hLimit 15 $ str s <+> fill ' ') <+> w + in newForm [ label "Hostname:" @@= + editHostname ciHostname Hostname + , label "Port:" @@= + editShowableField ciPort Port + , label "Username:" @@= + editTextField ciUsername Username (Just 1) + , label "Password:" @@= + editPasswordField ciPassword Password + ] + errorAttr :: AttrName errorAttr = "errorMessage" @@ -101,6 +105,8 @@ [ (editAttr, black `on` white) , (editFocusedAttr, black `on` yellow) , (errorAttr, fg red) + , (focusedFormInputAttr, black `on` yellow) + , (invalidFormInputAttr, white `on` red) ] credsDraw :: State -> [Widget Name] @@ -138,61 +144,14 @@ hCenter $ hLimit uiWidth $ vLimit 15 $ border $ vBox [ renderText "Please enter your Mattermost credentials to log in." - , padTop (Pad 1) $ - txt "Hostname: " <+> renderEditor (txt . T.concat) (st^.focus == Hostname) (st^.hostnameEdit) - , if validHostname st - then txt " " - else hCenter $ renderError $ txt "Invalid hostname" - , txt "Port: " <+> renderEditor (txt . T.concat) (st^.focus == Port) (st^.portEdit) - , if validPort st - then txt " " - else hCenter $ renderError $ txt "Invalid port" - , txt "Username: " <+> renderEditor (txt . T.concat) (st^.focus == Username) (st^.usernameEdit) - , padTop (Pad 1) $ - txt "Password: " <+> renderEditor toPassword (st^.focus == Password) (st^.passwordEdit) - , padTop (Pad 1) $ - hCenter $ renderText "Press Enter to log in or Esc to exit." + , padTop (Pad 1) $ renderForm (st^.loginForm) + , hCenter $ renderText "Press Enter to log in or Esc to exit." ] -onEvent :: State -> BrickEvent Name e -> EventM Name (Next State) +onEvent :: State -> BrickEvent Name () -> EventM Name (Next State) onEvent _ (VtyEvent (EvKey KEsc [])) = liftIO exitSuccess -onEvent st (VtyEvent (EvKey (KChar '\t') [])) = - continue $ st & focus %~ nextFocus onEvent st (VtyEvent (EvKey KEnter [])) = - if badState st then continue st else halt st -onEvent st (VtyEvent e) = do - let target :: Lens' State (Editor T.Text Name) - target = getFocusedEditor st - continue =<< handleEventLensed st target handleEditorEvent e -onEvent st _ = continue st - -nextFocus :: Name -> Name -nextFocus Hostname = Port -nextFocus Port = Username -nextFocus Username = Password -nextFocus Password = Hostname - -getFocusedEditor :: State -> Lens' State (Editor T.Text Name) -getFocusedEditor st = - case st^.focus of - Hostname -> hostnameEdit - Port -> portEdit - Username -> usernameEdit - Password -> passwordEdit - -badState :: State -> Bool -badState st = bad - where - -- check for valid (non-empty) contents - h = T.concat $ getEditContents $ st^.hostnameEdit - u = T.concat $ getEditContents $ st^.usernameEdit - p = T.concat $ getEditContents $ st^.passwordEdit - port :: Maybe Int - port = readMaybe (T.unpack $ T.concat $ getEditContents $ st^.portEdit) - bad = or [ T.null h - , T.null u - , T.null p - , isNothing port - , (not $ validHostname st) - , (not $ validPort st) - ] + if allFieldsValid (st^.loginForm) then halt st else continue st +onEvent st e = do + f' <- handleFormEvent e (st^.loginForm) + continue $ st & loginForm .~ f' diff --git a/src/Main.hs b/src/Main.hs --- a/src/Main.hs +++ b/src/Main.hs @@ -11,7 +11,9 @@ import Options import Types import InputHistory +import LastRunState import App +import Events (ensureKeybindingConsistency) main :: IO () main = do @@ -23,6 +25,19 @@ exitFailure Right c -> return c + case ensureKeybindingConsistency (configUserKeys config) of + Right () -> return () + Left err -> do + putStrLn $ "Configuration error: " <> err + exitFailure + finalSt <- runMatterhorn opts config writeHistory (finalSt^.csEditState.cedInputHistory) + + -- Try to write the run state to a file. If it fails, just print the error + -- and do not exit with a failure status because the run state file is optional. + done <- writeLastRunState finalSt + case done of + Left err -> putStrLn $ "Error in writing last run state: " <> err + Right _ -> return () diff --git a/src/Markdown.hs b/src/Markdown.hs --- a/src/Markdown.hs +++ b/src/Markdown.hs @@ -4,8 +4,7 @@ {-# LANGUAGE ViewPatterns #-} module Markdown - ( UserSet - , ChannelSet + ( MessageData(..) , renderMessage , renderText , renderText' @@ -34,7 +33,6 @@ import qualified Data.Text as T import qualified Data.Foldable as F import Data.Monoid (First(..), (<>)) -import Data.Time.Clock (UTCTime) import Data.Sequence ( Seq , ViewL(..) , ViewR(..) @@ -44,20 +42,20 @@ , viewr) import qualified Data.Sequence as S import qualified Skylighting as Sky -import Data.Set (Set) import qualified Data.Set as Set import qualified Graphics.Vty as V import Lens.Micro.Platform ((^.)) import Control.Monad (join) -import Network.Mattermost.Lenses (postUpdateAtL, postCreateAtL) +import Network.Mattermost.Lenses (postEditAtL, postCreateAtL) +import Network.Mattermost.Types (ServerTime(..)) import Themes -import Types (ChatState, getMessageForPostId, userSigil, normalChannelSigil) +import Types (HighlightSet(..), userSigil, normalChannelSigil) import Types.Posts import Types.Messages -type UserSet = Set Text -type ChannelSet = Set Text +emptyHSet :: HighlightSet +emptyHSet = HighlightSet Set.empty Set.empty omitUsernameTypes :: [MessageType] omitUsernameTypes = @@ -99,20 +97,32 @@ C.Para is -> S.singleton $ C.Para (is |> C.Str " " |> m) _ -> S.fromList [b, s] +-- | A bundled structure that includes all the information necessary +-- to render a given message +data MessageData = MessageData + { mdEditThreshold :: Maybe ServerTime + , mdShowOlderEdits :: Bool + , mdMessage :: Message + , mdParentMessage :: Maybe Message + , mdRenderReplyParent :: Bool + , mdHighlightSet :: HighlightSet + , mdIndentBlocks :: Bool + } + -- | renderMessage performs markdown rendering of the specified message. -- --- The 'mEditThreshold' argument specifies a time boundary where +-- The 'mdEditThreshold' argument specifies a time boundary where -- "edited" markers are not shown for any messages older than this -- mark (under the presumption that they are distracting for really --- old stuff). The mEditThreshold will be None if there is no +-- old stuff). The mdEditThreshold will be None if there is no -- boundary known yet; the boundary is typically set to the "new" -- message boundary. -- --- The 'showOlderEdits' argument is a value read from the user's +-- The 'mdShowOlderEdits' argument is a value read from the user's -- configuration file that indicates that "edited" markers should be --- shown for old messages (i.e., ignore the mEditThreshold value). -renderMessage :: ChatState -> Maybe UTCTime -> Bool -> Message -> Bool -> UserSet -> ChannelSet -> Bool -> Widget a -renderMessage st mEditThreshold showOlderEdits msg renderReplyParent uSet cSet indentBlocks = +-- shown for old messages (i.e., ignore the mdEditThreshold value). +renderMessage :: MessageData -> Widget a +renderMessage md@MessageData { mdMessage = msg, .. } = let msgUsr = case msg^.mUserName of Just u | msg^.mType `elem` omitUsernameTypes -> Nothing @@ -121,15 +131,15 @@ nameElems = case msgUsr of Just un | msg^.mType == CP Emote -> - [ B.txt "*", colorUsername un + [ B.txt "*", colorUsername un un , B.txt " " ] | msg^.mFlagged -> - [ colorUsername un + [ colorUsername un un , B.txt "[!]: " ] | otherwise -> - [ colorUsername un + [ colorUsername un un , B.txt ": " ] Nothing -> [] @@ -139,29 +149,35 @@ maybeAugment bs = case msg^.mOriginalPost of Nothing -> bs Just p -> - if p^.postUpdateAtL > p^.postCreateAtL - then case mEditThreshold of - Just cutoff | p^.postUpdateAtL >= cutoff -> + if p^.postEditAtL > p^.postCreateAtL + then case mdEditThreshold of + Just cutoff | p^.postEditAtL >= cutoff -> addEditSentinel editRecentlyMarkingSentinel bs - _ -> if showOlderEdits + _ -> if mdShowOlderEdits then addEditSentinel editMarkingSentinel bs else bs else bs augmentedText = maybeAugment $ msg^.mText - rmd = renderMarkdown uSet cSet augmentedText + rmd = renderMarkdown mdHighlightSet augmentedText msgWidget = (layout nameElems rmd . viewl) augmentedText withParent p = (replyArrow <+> p) B.<=> msgWidget - in if not renderReplyParent + in if not mdRenderReplyParent then msgWidget else case msg^.mInReplyToMsg of NotAReply -> msgWidget - InReplyTo parentId -> - case getMessageForPostId st parentId of + InReplyTo _ -> + case mdParentMessage of Nothing -> withParent (B.str "[loading...]") Just pm -> - let parentMsg = renderMessage st mEditThreshold False pm False uSet cSet False + let parentMsg = renderMessage md + { mdShowOlderEdits = False + , mdMessage = pm + , mdParentMessage = Nothing + , mdRenderReplyParent = False + , mdIndentBlocks = False + } in withParent (addEllipsis $ B.forceAttr replyParentAttr parentMsg) where @@ -175,7 +191,7 @@ | F.any breakCheck inlns = multiLnLayout n m layout n m _ = hBox $ join [n, return m] multiLnLayout n m = - if indentBlocks + if mdIndentBlocks then vBox [ hBox n , hBox [B.txt " ", m] ] @@ -201,9 +217,9 @@ cursorSentinel = '‸' -- Render markdown with username highlighting -renderMarkdown :: UserSet -> ChannelSet -> Blocks -> Widget a -renderMarkdown uSet cSet = - B.vBox . F.toList . fmap (toWidget uSet cSet) . addBlankLines +renderMarkdown :: HighlightSet -> Blocks -> Widget a +renderMarkdown hSet = + B.vBox . F.toList . fmap (blockToWidget hSet) . addBlankLines -- Add blank lines only between adjacent elements of the same type, to -- save space @@ -229,10 +245,10 @@ -- Render text to markdown without username highlighting renderText :: Text -> Widget a -renderText txt = renderText' Set.empty Set.empty txt +renderText txt = renderText' emptyHSet txt -renderText' :: UserSet -> ChannelSet -> Text -> Widget a -renderText' uSet cSet txt = renderMarkdown uSet cSet bs +renderText' :: HighlightSet -> Text -> Widget a +renderText' hSet txt = renderMarkdown hSet bs where C.Doc _ bs = C.markdown C.def txt vBox :: F.Foldable f => f (Widget a) -> Widget a @@ -243,26 +259,26 @@ -- -class ToWidget t where - toWidget :: UserSet -> ChannelSet -> t -> Widget a +-- class ToWidget t where +-- toWidget :: HighlightSet -> t -> Widget a header :: Int -> Widget a header n = B.txt (T.replicate n "#") -instance ToWidget Block where - toWidget uPat cPat (C.Para is) = toInlineChunk is uPat cPat - toWidget uPat cPat (C.Header n is) = +blockToWidget :: HighlightSet -> Block -> Widget a +blockToWidget hSet (C.Para is) = toInlineChunk is hSet +blockToWidget hSet (C.Header n is) = B.withDefAttr clientHeaderAttr $ - hBox [header n, B.txt " ", toInlineChunk is uPat cPat] - toWidget uPat cPat (C.Blockquote is) = - addQuoting (vBox $ fmap (toWidget uPat cPat) is) - toWidget uPat cPat (C.List _ l bs) = toList l bs uPat cPat - toWidget _ _ (C.CodeBlock ci tx) = + hBox [header n, B.txt " ", toInlineChunk is hSet] +blockToWidget hSet (C.Blockquote is) = + addQuoting (vBox $ fmap (blockToWidget hSet) is) +blockToWidget hSet (C.List _ l bs) = toList l bs hSet +blockToWidget _ (C.CodeBlock ci tx) = let f = maybe rawCodeBlockToWidget codeBlockToWidget mSyntax mSyntax = Sky.lookupSyntax (C.codeLang ci) Sky.defaultSyntaxMap in f tx - toWidget _ _ (C.HtmlBlock txt) = textWithCursor txt - toWidget _ _ (C.HRule) = B.vLimit 1 (B.fill '*') +blockToWidget _ (C.HtmlBlock txt) = textWithCursor txt +blockToWidget _ (C.HRule) = B.vLimit 1 (B.fill '*') quoteChar :: Char quoteChar = '>' @@ -308,17 +324,17 @@ expandEmpty s = s in padding <+> (B.vBox $ textWithCursor <$> theLines) -toInlineChunk :: Inlines -> UserSet -> ChannelSet -> Widget a -toInlineChunk is uSet cSet = B.Widget B.Fixed B.Fixed $ do +toInlineChunk :: Inlines -> HighlightSet -> Widget a +toInlineChunk is hSet = B.Widget B.Fixed B.Fixed $ do ctx <- B.getContext let width = ctx^.B.availWidthL fs = toFragments is - ws = fmap gatherWidgets (split width uSet cSet fs) + ws = fmap gatherWidgets (split width hSet fs) B.render (vBox (fmap hBox ws)) -toList :: ListType -> [Blocks] -> UserSet -> ChannelSet -> Widget a -toList lt bs uSet cSet = vBox - [ B.txt i <+> (vBox (fmap (toWidget uSet cSet) b)) +toList :: ListType -> [Blocks] -> HighlightSet -> Widget a +toList lt bs hSet = vBox + [ B.txt i <+> (vBox (fmap (blockToWidget hSet) b)) | b <- bs | i <- is ] where is = case lt of C.Bullet _ -> repeat ("• ") @@ -353,7 +369,7 @@ | Emph | Strong | Code - | User + | User Text | Link Text | Emoji | Channel @@ -411,22 +427,26 @@ , splitCurrCol :: Int } -separate :: UserSet -> ChannelSet -> Seq Fragment -> Seq Fragment -separate uSet cSet sq = case viewl sq of +separate :: HighlightSet -> Seq Fragment -> Seq Fragment +separate hSet sq = case viewl sq of Fragment (TStr s) n :< xs -> gatherStrings s n xs - Fragment x n :< xs -> Fragment x n <| separate uSet cSet xs + Fragment x n :< xs -> Fragment x n <| separate hSet xs EmptyL -> S.empty - where gatherStrings s n rs = + where HighlightSet { hUserSet = uSet, hChannelSet = cSet } = hSet + gatherStrings s n rs = let s' = removeCursor s in case viewl rs of _ | s' `Set.member` uSet || - ((T.singleton userSigil) `T.isPrefixOf` s' && (T.drop 1 s' `Set.member` uSet)) -> - buildString s n <| separate uSet cSet rs - _ | ((T.singleton normalChannelSigil) `T.isPrefixOf` s' && (T.drop 1 s' `Set.member` cSet)) -> - buildString s n <| separate uSet cSet rs + (userSigil `T.isPrefixOf` s' && (T.drop 1 s' `Set.member` uSet)) -> + buildString s n <| separate hSet rs + _ | (normalChannelSigil `T.isPrefixOf` s' && (T.drop 1 s' `Set.member` cSet)) -> + buildString s n <| separate hSet rs + Fragment (TStr s'') _ :< _ + | s'' == userSigil || s'' == normalChannelSigil -> + buildString s n <| separate hSet rs Fragment (TStr s'') n' :< xs | n == n' -> gatherStrings (s <> s'') n xs - Fragment _ _ :< _ -> buildString s n <| separate uSet cSet rs + Fragment _ _ :< _ -> buildString s n <| separate hSet rs EmptyL -> S.singleton (buildString s n) buildString s n = let s' = removeCursor s @@ -435,12 +455,12 @@ ":" `T.isSuffixOf` s' && textWidth s' > 2 -> Fragment (TStr s) Emoji - | s' `Set.member` uSet -> - Fragment (TStr s) User - | (T.singleton userSigil) `T.isPrefixOf` (removeCursor s) && - (T.drop 1 (removeCursor s) `Set.member` uSet) -> - Fragment (TStr s) User - | (T.singleton normalChannelSigil) `T.isPrefixOf` (removeCursor s) && + | removeCursor s' `Set.member` uSet -> + Fragment (TStr s) (User s) + | Just uname <- userSigil `T.stripPrefix` removeCursor s + , removeCursor uname `Set.member` uSet -> + Fragment (TStr s) (User uname) + | normalChannelSigil `T.isPrefixOf` (removeCursor s) && (T.drop 1 (removeCursor s) `Set.member` cSet) -> Fragment (TStr s) Channel | otherwise -> Fragment (TStr s) n @@ -448,10 +468,10 @@ removeCursor :: T.Text -> T.Text removeCursor = T.filter (/= cursorSentinel) -split :: Int -> UserSet -> ChannelSet -> Seq Fragment -> Seq (Seq Fragment) -split maxCols uSet cSet = splitChunks +split :: Int -> HighlightSet -> Seq Fragment -> Seq (Seq Fragment) +split maxCols hSet = splitChunks . go (SplitState (S.singleton S.empty) 0) - . separate uSet cSet + . separate hSet where go st (viewl-> f :< fs) = go st' fs where st' = if | fTextual f == TSoftBreak || fTextual f == TLineBreak -> @@ -504,21 +524,24 @@ where go s t (viewl-> (Fragment f s' :< xs)) | s == s' = go s (t <> strOf f) xs go s t xs = - let w = case s of - Normal -> textWithCursor t - Emph -> B.withDefAttr clientEmphAttr (textWithCursor t) + let rawText = B.txt (removeCursor t) + rawWidget = case s of + Normal -> rawText + Emph -> B.withDefAttr clientEmphAttr rawText Edited -> B.withDefAttr editedMarkingAttr $ B.txt t EditedRecently -> B.withDefAttr editedRecentlyMarkingAttr $ B.txt t - Strong -> B.withDefAttr clientStrongAttr (textWithCursor t) - Code -> B.withDefAttr codeAttr (textWithCursor t) + Strong -> B.withDefAttr clientStrongAttr rawText + Code -> B.withDefAttr codeAttr rawText Link l -> B.modifyDefAttr (`V.withURL` l) - (B.withDefAttr urlAttr (textWithCursor t)) - Emoji -> B.withDefAttr emojiAttr (textWithCursor t) - User -> B.withDefAttr (attrForUsername $ removeCursor t) - (textWithCursor t) - Channel -> B.withDefAttr channelNameAttr (textWithCursor t) - in w <| gatherWidgets xs + (B.withDefAttr urlAttr rawText) + Emoji -> B.withDefAttr emojiAttr rawText + User u -> colorUsername u t + Channel -> B.withDefAttr channelNameAttr rawText + widget + | T.any (== cursorSentinel) t = B.visible rawWidget + | otherwise = rawWidget + in widget <| gatherWidgets xs gatherWidgets _ = S.empty diff --git a/src/State.hs b/src/State.hs --- a/src/State.hs +++ b/src/State.hs @@ -33,6 +33,7 @@ , channelPageUp , channelPageDown , isCurrentChannel + , isRecentChannel , getNewMessageCutoff , getEditedMessageCutoff , setChannelTopic @@ -59,6 +60,7 @@ -- * Working with users , handleNewUser , updateStatus + , handleTypingUser -- * Startup/reconnect management , refreshChannelsAndUsers @@ -111,10 +113,11 @@ import Brick.Widgets.Edit (getEditContents, editContentsL) import Brick.Widgets.List (list, listMoveTo, listSelectedElement) import Control.Applicative -import Control.Exception (SomeException, try) -import Control.Monad.IO.Class (liftIO) +import Control.Concurrent.Async (runConcurrently, Concurrently(..), concurrently) import Control.Concurrent (MVar, putMVar, forkIO) import qualified Control.Concurrent.STM as STM +import Control.Exception (SomeException, try) +import Control.Monad.IO.Class (liftIO) import Data.Char (isAlphaNum) import Brick.Main (getVtyHandle, viewportScroll, vScrollToBeginning, vScrollBy, vScrollToEnd) import Brick.Widgets.Edit (applyEdit) @@ -122,14 +125,14 @@ import qualified Data.ByteString as BS import Data.Function (on) import Data.Text.Zipper (textZipper, clearZipper, insertMany, gotoEOL) -import Data.Time.Clock (UTCTime) import qualified Data.HashMap.Strict as HM import qualified Data.Sequence as Seq import Data.List (sort, findIndex) -import Data.Maybe (maybeToList, isJust, catMaybes, isNothing) +import Data.Maybe (maybeToList, isJust, fromJust, catMaybes, isNothing) import Data.Monoid ((<>)) import qualified Data.Set as Set import qualified Data.Text as T +import Data.Time (getCurrentTime) import qualified Data.Vector as V import qualified Data.Foldable as F import Graphics.Vty (outputIface) @@ -143,9 +146,8 @@ import System.Environment.XDG.BaseDir (getUserCacheDir) import System.FilePath -import Network.Mattermost -import Network.Mattermost.Types (NotifyOption(..), GroupChannelPreference(..), - preferenceToGroupChannelPreference) +import qualified Network.Mattermost.Endpoints as MM +import Network.Mattermost.Types import Network.Mattermost.Lenses import Config @@ -170,8 +172,8 @@ -- | Refresh information about a specific channel. The channel -- metadata is refreshed, and if this is a loaded channel, the -- scrollback is updated as well. -refreshChannel :: Bool -> ChannelWithData -> MH () -refreshChannel refreshMessages cwd@(ChannelWithData chan _) = do +refreshChannel :: Bool -> Channel -> ChannelMember -> MH () +refreshChannel refreshMessages chan member = do let cId = getId chan curId <- use csCurrentChannelId @@ -184,9 +186,9 @@ -- If this channel is unknown, register it first. mChan <- preuse (csChannel(cId)) when (isNothing mChan) $ - handleNewChannel False cwd + handleNewChannel False chan member - updateChannelInfo cId cwd + updateChannelInfo cId chan member -- If this is an active channel or the current channel, also -- update the Messages to retrieve any that might have been @@ -197,15 +199,14 @@ refreshChannelById :: Bool -> ChannelId -> MH () refreshChannelById refreshMessages cId = do session <- use (csResources.crSession) - myTeamId <- use (csMyTeam.teamIdL) doAsyncWith Preempt $ do - cwd <- mmGetChannel session myTeamId cId - return $ refreshChannel refreshMessages cwd + cwd <- MM.mmGetChannel cId session + member <- MM.mmGetChannelMember cId UserMe session + return $ refreshChannel refreshMessages cwd member createGroupChannel :: T.Text -> MH () createGroupChannel usernameList = do users <- use csUsers - myTeamId <- use (csMyTeam.teamIdL) me <- use csMe let usernames = T.words usernameList @@ -224,15 +225,16 @@ when (length results == length usernames) $ do session <- use (csResources.crSession) doAsyncWith Preempt $ do - chan <- mmCreateGroupChannel session results + chan <- MM.mmCreateGroupMessageChannel (Seq.fromList results) session let pref = showGroupChannelPref (channelId chan) (me^.userIdL) -- It's possible that the channel already existed, in which -- case we want to request a preference change to show it. - mmSetPreferences session (me^.userIdL) $ Seq.fromList [pref] - cwd <- mmGetChannel session myTeamId (channelId chan) + MM.mmSaveUsersPreferences UserMe (Seq.singleton pref) session -- (me^.userIdL) $ Seq.fromList [pref] + cwd <- MM.mmGetChannel (channelId chan) session + member <- MM.mmGetChannelMember (channelId chan) UserMe session return $ do applyPreferenceChange pref - handleNewChannel True cwd + handleNewChannel True cwd member channelHiddenPreference :: ChannelId -> MH Bool channelHiddenPreference cId = do @@ -277,29 +279,44 @@ -- occurs. refreshChannelsAndUsers :: MH () refreshChannelsAndUsers = do + -- The below code is a duplicate of mmGetAllChannelsWithDataForUser function, + -- which has been inlined here to gain a concurrency benefit. session <- use (csResources.crSession) myTeamId <- use (csMyTeam.teamIdL) - myId <- use (csMe.userIdL) + let userQuery = MM.defaultUserQuery + { MM.userQueryPage = Just 0 + , MM.userQueryPerPage = Just 10000 + , MM.userQueryInTeam = Just myTeamId + } doAsyncWith Preempt $ do - chansWithData <- mmGetAllChannelsWithDataForUser session myTeamId myId - uMap <- mmGetProfiles session myTeamId 0 10000 + (chans, datas, users) <- runConcurrently $ (,,) + <$> Concurrently (MM.mmGetChannelsForUser UserMe myTeamId session) + <*> Concurrently (MM.mmGetChannelMembersForUser UserMe myTeamId session) + <*> Concurrently (MM.mmGetUsers userQuery session) + + let dataMap = HM.fromList $ F.toList $ (\d -> (channelMemberChannelId d, d)) <$> datas + mkPair chan = (chan, fromJust $ HM.lookup (channelId chan) dataMap) + chansWithData = mkPair <$> chans + return $ do - forM_ (HM.elems uMap) $ \u -> do + forM_ users $ \u -> do when (not $ userDeleted u) $ do knownUsers <- use csUsers case findUserById (getId u) knownUsers of Just _ -> return () Nothing -> handleNewUserDirect u - forM_ (HM.elems chansWithData) $ refreshChannel True + forM_ chansWithData $ uncurry (refreshChannel True) + userSet <- use (csResources.crUserIdSet) + liftIO $ STM.atomically $ STM.writeTVar userSet (fmap userId users) lock <- use (csResources.crUserStatusLock) - doAsyncWith Preempt $ updateUserStatuses lock session + doAsyncWith Preempt $ updateUserStatuses userSet lock session -- | Update the indicted Channel entry with the new data retrieved from -- the Mattermost server. Also update the channel name if it changed. -updateChannelInfo :: ChannelId -> ChannelWithData -> MH () -updateChannelInfo cid cwd@(ChannelWithData new _) = do +updateChannelInfo :: ChannelId -> Channel -> ChannelMember -> MH () +updateChannelInfo cid new member = do mOldChannel <- preuse $ csChannel(cid) case mOldChannel of Nothing -> return () @@ -312,7 +329,7 @@ removeChannelName oldName addChannelName (channelType new) cid newName - csChannel(cid).ccInfo %= channelInfoFromChannelWithData cwd + csChannel(cid).ccInfo %= channelInfoFromChannelWithData new member addChannelName :: Type -> ChannelId -> T.Text -> MH () addChannelName chType cid name = do @@ -366,7 +383,7 @@ withChannel cId $ \chan -> do let last_pId = getLatestPostId (chan^.ccContents.cdMessages) newCutoff = chan^.ccInfo.cdNewMessageIndicator - fetchMessages s t c = do + fetchMessages s _ c = do let fc = case last_pId of Nothing -> F1 -- or F4 Just pId -> @@ -396,13 +413,17 @@ if m^.mDate >= ct then F3b pId else F3a - op = case fc of - F1 -> mmGetPosts s t c - F2 pId -> mmGetPostsAfter s t c pId - F3a -> mmGetPosts s t c - F3b pId -> mmGetPostsBefore s t c pId - F4 -> mmGetPosts s t c - op 0 numScrollbackPosts + query = MM.defaultPostQuery + { MM.postQueryPage = Just 0 + , MM.postQueryPerPage = Just numScrollbackPosts + } + finalQuery = case fc of + F1 -> query -- mmGetPosts s t c + F2 pId -> query { MM.postQueryAfter = Just pId } -- mmGetPostsAfter s t c pId + F3a -> query -- mmGetPosts s t c + F3b pId -> query { MM.postQueryBefore = Just pId } -- mmGetPostsBefore s t c pId + F4 -> query -- mmGetPosts s t c + MM.mmGetPostsForChannel c finalQuery s -- op 0 numScrollbackPosts asPending doAsyncChannelMM prio cId fetchMessages addObtainedMessages @@ -484,7 +505,7 @@ case msg^.mOriginalPost of Just p -> doAsyncChannelMM Preempt cId - (\s t c -> mmDeletePost s t c (postId p)) + (\s _ _ -> MM.mmDeletePost (postId p) s) (\_ _ -> do csEditState.cedEditMode .= NewPost csMode .= Main) Nothing -> return () @@ -508,6 +529,9 @@ isCurrentChannel :: ChatState -> ChannelId -> Bool isCurrentChannel st cId = st^.csCurrentChannelId == cId +isRecentChannel :: ChatState -> ChannelId -> Bool +isRecentChannel st cId = st^.csRecentChannel == Just cId + -- | Update the UI to reflect the flagged/unflagged state of a -- message. This __does not__ talk to the Mattermost server, but -- rather is the function we call when the Mattermost server notifies @@ -553,8 +577,8 @@ session <- use (csResources.crSession) myId <- use (csMe.userIdL) doAsyncWith Normal $ do - let doFlag = if f then mmFlagPost else mmUnflagPost - doFlag session myId pId + let doFlag = if f then MM.mmFlagPost else MM.mmUnflagPost + doFlag myId pId session return $ return () -- | Tell the server that the message we currently have selected @@ -625,20 +649,22 @@ startJoinChannel = do session <- use (csResources.crSession) myTeamId <- use (csMyTeam.teamIdL) + myChannels <- use (csChannels.to (filteredChannelIds (const True))) doAsyncWith Preempt $ do -- We don't get to just request all channels, so we request channels in -- chunks of 50. A better UI might be to request an initial set and -- then wait for the user to demand more. let fetchCount = 50 loop acc start = do - newChans <- mmGetMoreChannels session myTeamId start fetchCount + newChans <- MM.mmGetPublicChannels myTeamId (Just start) (Just fetchCount) session let chans = acc <> newChans if length newChans < fetchCount then return chans - else loop chans (start+fetchCount) - chans <- loop mempty 0 + else loop chans (start+1) + chans <- Seq.filter (\ c -> not (channelId c `elem` myChannels)) <$> loop mempty 0 + let sortedChans = V.fromList $ F.toList $ Seq.sortBy (compare `on` channelName) chans return $ do - csJoinChannelList .= (Just $ list JoinChannelList (V.fromList $ F.toList chans) 1) + csJoinChannelList .= (Just $ list JoinChannelList sortedChans 2) csMode .= JoinChannel csJoinChannelList .= Nothing @@ -646,7 +672,9 @@ joinChannel :: Channel -> MH () joinChannel chan = do csMode .= Main - doAsyncChannelMM Preempt (getId chan) mmJoinChannel endAsyncNOP + myId <- use (csMe.userIdL) + let member = MinChannelMember myId (getId chan) + doAsyncChannelMM Preempt (getId chan) (\ s _ c -> MM.mmAddUser c member s) endAsyncNOP -- | When another user adds us to a channel, we need to fetch the -- channel info for that channel. @@ -654,9 +682,10 @@ handleChannelInvite cId = do st <- use id doAsyncWith Normal $ do - tryMM (mmGetChannel (st^.csResources.crSession) (st^.csMyTeam.teamIdL) cId) + member <- MM.mmGetChannelMember cId UserMe (st^.csResources.crSession) + tryMM (MM.mmGetChannel cId (st^.csResources.crSession)) (\cwd -> return $ do - handleNewChannel False cwd + handleNewChannel False cwd member asyncFetchScrollback Normal cId) addUserToCurrentChannel :: T.Text -> MH () @@ -667,9 +696,9 @@ Just (uid, _) -> do cId <- use csCurrentChannelId session <- use (csResources.crSession) - myTeamId <- use (csMyTeam.teamIdL) + let channelMember = MinChannelMember uid cId doAsyncWith Normal $ do - tryMM (void $ mmChannelAddUser session myTeamId cId uid) + tryMM (void $ MM.mmAddUser cId channelMember session) -- session myTeamId cId uid) (const $ return (return ())) _ -> do postErrorMessage ("No such user: " <> uname) @@ -683,7 +712,7 @@ cId <- use csCurrentChannelId session <- use (csResources.crSession) doAsyncWith Normal $ do - tryMM (void $ mmChannelRemoveUser session cId uid) + tryMM (void $ MM.mmRemoveUserFromChannel cId (UserById uid) session) (const $ return (return ())) _ -> do postErrorMessage ("No such user: " <> uname) @@ -723,15 +752,15 @@ -- by the delete argument. let func = case cInfo^.cdType of Private -> case all isMe members of - True -> mmDeleteChannel - False -> mmLeaveChannel + True -> (\ s _ c -> MM.mmDeleteChannel c s) + False -> (\ s _ c -> MM.mmRemoveUserFromChannel c UserMe s) Group -> \s _ _ -> - mmSetPreferences s (me^.userIdL) $ - Seq.fromList [hideGroupChannelPref cId $ me^.userIdL] + let pref = hideGroupChannelPref cId (me^.userIdL) + in MM.mmSaveUsersPreferences UserMe (Seq.singleton pref) s _ -> if delete - then mmDeleteChannel - else mmLeaveChannel + then (\ s _ c -> MM.mmDeleteChannel c s) + else (\ s _ c -> MM.mmRemoveUserFromChannel c UserMe s) doAsyncChannelMM Preempt cId func endAsyncNOP ) @@ -792,9 +821,14 @@ postInfoMessage msgStr) fetchChannelMembers :: Session -> TeamId -> ChannelId -> IO [User] -fetchChannelMembers s t c = do - chanUserMap <- mmGetChannelMembers s t c 0 10000 - return $ snd <$> HM.toList chanUserMap +fetchChannelMembers s _ c = do + let query = MM.defaultUserQuery + { MM.userQueryPage = Just 0 + , MM.userQueryPerPage = Just 10000 + , MM.userQueryInChannel = Just c + } + chanUserMap <- MM.mmGetUsers query s + return $ F.toList chanUserMap -- | Called on async completion when the currently viewed channel has -- been updated (i.e., just switched to this channel) to update local @@ -835,8 +869,10 @@ -- updating the client data, but it's also immune to any new or -- removed Message date fields, or anything else that would -- contribute to the viewed/updated times on the server. - doAsyncChannelMM Preempt cId mmGetChannel - (\pcid cwd -> csChannel(pcid).ccInfo %= channelInfoFromChannelWithData cwd) + doAsyncChannelMM Preempt cId (\ s _ _ -> + (,) <$> MM.mmGetChannel cId s + <*> MM.mmGetChannelMember cId UserMe s) + (\pcid (cwd, member) -> csChannel(pcid).ccInfo %= channelInfoFromChannelWithData cwd member) -- Update the old channel's previous viewed time (allows tracking of new messages) case prevId of Nothing -> return () @@ -857,7 +893,7 @@ -- Only do this if we're connected to avoid triggering noisy exceptions. pId <- use csRecentChannel doAsyncChannelMM Preempt cId - (\s t c -> mmViewChannel s t c pId) + (\s _ c -> MM.mmViewChannel UserMe c pId s) (\c () -> setLastViewedFor pId c) Disconnected -> -- Cannot update server; make no local updates to avoid @@ -1026,8 +1062,12 @@ cId <- use csCurrentChannelId withChannel cId $ \chan -> let offset = length $ chan^.ccContents.cdMessages + query = MM.defaultPostQuery + { MM.postQueryPage = Just (offset `div` pageAmount) + , MM.postQueryPerPage = Just pageAmount + } in asPending doAsyncChannelMM Preempt cId - (\s t c -> mmGetPosts s t c offset pageAmount) + (\s _ c -> MM.mmGetPostsForChannel c query s) (\c p -> do addObtainedMessages c p mh $ invalidateCacheEntry (ChannelMessages cId)) @@ -1047,8 +1087,8 @@ channelByName :: ChatState -> T.Text -> Maybe ChannelId channelByName st n - | (T.singleton normalChannelSigil) `T.isPrefixOf` n = st ^. csNames . cnToChanId . at (T.tail n) - | (T.singleton userSigil) `T.isPrefixOf` n = st ^. csNames . cnToChanId . at (T.tail n) + | normalChannelSigil `T.isPrefixOf` n = st ^. csNames . cnToChanId . at (T.tail n) + | userSigil `T.isPrefixOf` n = st ^. csNames . cnToChanId . at (T.tail n) | otherwise = st ^. csNames . cnToChanId . at n -- | This switches to the named channel or creates it if it is a missing @@ -1088,21 +1128,22 @@ else if name `elem` users && not (name `HM.member` nameToChanId) then do -- We have a user of that name but no channel. Time to make one! - tId <- use (csMyTeam.teamIdL) + myId <- use (csMe.userIdL) Just uId <- use (csNames.cnToUserId.at(name)) session <- use (csResources.crSession) doAsyncWith Normal $ do -- create a new channel - nc <- mmCreateDirect session tId uId - cwd <- mmGetChannel session tId (getId nc) - return $ handleNewChannel True cwd + nc <- MM.mmCreateDirectMessageChannel (uId, myId) session -- tId uId + cwd <- MM.mmGetChannel (getId nc) session + member <- MM.mmGetChannelMember (getId nc) UserMe session + return $ handleNewChannel True cwd member else postErrorMessage ("No channel or user named " <> name) createOrdinaryChannel :: T.Text -> MH () createOrdinaryChannel name = do - tId <- use (csMyTeam.teamIdL) session <- use (csResources.crSession) + myTeamId <- use (csMyTeam.teamIdL) doAsyncWith Preempt $ do -- create a new chat channel let slug = T.map (\ c -> if isAlphaNum c then c else '-') (T.toLower name) @@ -1112,13 +1153,16 @@ , minChannelPurpose = Nothing , minChannelHeader = Nothing , minChannelType = Ordinary + , minChannelTeamId = myTeamId } - tryMM (do c <- mmCreateChannel session tId minChannel - mmGetChannel session tId (getId c) + tryMM (do c <- MM.mmCreateChannel minChannel session + chan <- MM.mmGetChannel (getId c) session + member <- MM.mmGetChannelMember (getId c) UserMe session + return (chan, member) ) - (return . handleNewChannel True) + (return . uncurry (handleNewChannel True)) -handleNewChannel :: Bool -> ChannelWithData -> MH () +handleNewChannel :: Bool -> Channel -> ChannelMember -> MH () handleNewChannel = handleNewChannel_ True handleNewChannel_ :: Bool @@ -1129,10 +1173,11 @@ -> Bool -- ^ Whether to switch to the new channel once it has -- been installed. - -> ChannelWithData + -> Channel -- ^ The channel to install. + -> ChannelMember -> MH () -handleNewChannel_ permitPostpone switch cwd@(ChannelWithData nc cData) = do +handleNewChannel_ permitPostpone switch nc member = do -- Only add the channel to the state if it isn't already known. mChan <- preuse (csChannel(getId nc)) case mChan of @@ -1140,7 +1185,7 @@ Nothing -> do -- Create a new ClientChannel structure let cChannel = makeClientChannel nc & - ccInfo %~ channelInfoFromChannelWithData (ChannelWithData nc cData) + ccInfo %~ channelInfoFromChannelWithData nc member st <- use id @@ -1188,7 +1233,7 @@ True -> do handleNewUser otherUserId doAsyncWith Normal $ - return $ handleNewChannel_ False switch cwd + return $ handleNewChannel_ False switch nc member return Nothing Just ncUsername -> return $ Just $ ncUsername @@ -1315,9 +1360,9 @@ case st ^? csChannel(postChannelId new) of Nothing -> do session <- use (csResources.crSession) - myTeamId <- use (csMyTeam.teamIdL) doAsyncWith Preempt $ do - cwd@(ChannelWithData nc _) <- mmGetChannel session myTeamId (postChannelId new) + nc <- MM.mmGetChannel (postChannelId new) session + member <- MM.mmGetChannelMember (postChannelId new) UserMe session let chType = nc^.channelTypeL pref = showGroupChannelPref (postChannelId new) (st^.csMe.userIdL) @@ -1330,7 +1375,7 @@ -- (That, in turn, triggers a channel refresh.) if chType == Group then applyPreferenceChange pref - else refreshChannel True cwd + else refreshChannel True nc member addMessageToState newPostData >>= postProcessMessageAdd @@ -1373,15 +1418,16 @@ case getMessageForPostId st parentId of Nothing -> do doAsyncChannelMM Preempt cId - (\s t c -> mmGetPost s t c parentId) - (\_ p -> + (\s _ _ -> MM.mmGetThread parentId s) + (\_ p -> do + st' <- use id let postMap = HM.fromList [ ( pId - , clientPostToMessage st + , clientPostToMessage st' (toClientPost x (x^.postParentIdL)) ) | (pId, x) <- HM.toList (p^.postsPostsL) ] - in csPostMap %= HM.union postMap + csPostMap %= HM.union postMap ) _ -> return () _ -> return () @@ -1421,7 +1467,7 @@ cc <- st^?csChannel(cId) return $ cc^.ccInfo.cdNewMessageIndicator -getEditedMessageCutoff :: ChannelId -> ChatState -> Maybe UTCTime +getEditedMessageCutoff :: ChannelId -> ChatState -> Maybe ServerTime getEditedMessageCutoff cId st = do cc <- st^?csChannel(cId) cc^.ccInfo.cdEditedMessageThreshold @@ -1456,8 +1502,9 @@ setChannelTopic :: T.Text -> MH () setChannelTopic msg = do cId <- use csCurrentChannelId + let patch = defaultChannelPatch { channelPatchHeader = Just msg } doAsyncChannelMM Preempt cId - (\s t c -> mmSetChannelHeader s t c msg) + (\s _ _ -> MM.mmPatchChannel cId patch s) (\_ _ -> return ()) channelHistoryForward :: MH () @@ -1759,8 +1806,7 @@ -- open the local copy. let sess = st^.csResources.crSession - info <- mmGetFileInfo sess fId - contents <- mmGetFile sess fId + (info, contents) <- concurrently (MM.mmGetMetadataForFile fId sess) (MM.mmGetFile fId sess) cacheDir <- getUserCacheDir xdgName let dir = cacheDir "files" T.unpack (idString fId) @@ -1858,26 +1904,17 @@ let m = "Cannot send messages while disconnected." postErrorMessage m Connected -> do - let myId = st^.csMe.userIdL - chanId = st^.csCurrentChannelId - theTeamId = st^.csMyTeam.teamIdL + let chanId = st^.csCurrentChannelId doAsync Preempt $ do case mode of NewPost -> do - pendingPost <- mkPendingPost msg myId chanId - void $ mmPost (st^.csResources.crSession) theTeamId pendingPost + let pendingPost = rawPost msg chanId + void $ MM.mmCreatePost pendingPost (st^.csResources.crSession) Replying _ p -> do - pendingPost <- mkPendingPost msg myId chanId - let modifiedPost = - pendingPost { pendingPostParentId = Just $ postId p - , pendingPostRootId = Just $ postId p - } - void $ mmPost (st^.csResources.crSession) theTeamId modifiedPost + let pendingPost = (rawPost msg chanId) { rawPostRootId = Just (postId p) } + void $ MM.mmCreatePost pendingPost (st^.csResources.crSession) Editing p -> do - let modifiedPost = p { postMessage = msg - , postPendingPostId = Nothing - } - void $ mmUpdatePost (st^.csResources.crSession) theTeamId modifiedPost + void $ MM.mmUpdatePost (postId p) (postUpdate msg) (st^.csResources.crSession) handleNewUserDirect :: User -> MH () handleNewUserDirect newUser = do @@ -1886,15 +1923,21 @@ csUsers %= addUser newUserId usrInfo csNames . cnUsers %= (sort . ((newUser^.userUsernameL):)) csNames . cnToUserId . at (newUser^.userUsernameL) .= Just newUserId + userSet <- use (csResources.crUserIdSet) + liftIO $ STM.atomically $ STM.modifyTVar userSet $ (newUserId Seq.<|) handleNewUser :: UserId -> MH () handleNewUser newUserId = doAsyncMM Normal getUserInfo updateUserState - where getUserInfo session team = - do nUser <- mmGetUser session newUserId + where getUserInfo session _ = + do (nUser, users) <- concurrently (MM.mmGetUser (UserById newUserId) session) + (MM.mmGetUsers MM.defaultUserQuery + { MM.userQueryPage = Just 0 + , MM.userQueryPerPage = Just 10000 + } session) + let teamUsers = HM.fromList [ (userId u, u) | u <- F.toList users ] -- Also re-load the team members so we can tell -- whether the new user is in the current user's -- team. - teamUsers <- mmGetProfiles session team 0 10000 let usrInfo = userInfoFromUser nUser (HM.member newUserId teamUsers) return (nUser, usrInfo) updateUserState :: (User, UserInfo) -> MH () @@ -1903,3 +1946,13 @@ do csUsers %= addUser newUserId uInfo csNames . cnUsers %= (sort . ((newUser^.userUsernameL):)) csNames . cnToUserId . at (newUser^.userUsernameL) .= Just newUserId + userSet <- use (csResources.crUserIdSet) + liftIO $ STM.atomically $ STM.modifyTVar userSet $ (newUserId Seq.<|) + +-- | Handle the typing events from the websocket to show the currently typing users on UI +handleTypingUser :: UserId -> ChannelId -> MH () +handleTypingUser uId cId = do + config <- use (csResources.crConfiguration) + when (configShowTypingIndicator config) $ do + ts <- liftIO getCurrentTime -- get time now + csChannels %= modifyChannelById cId (addChannelTypingUser uId ts) diff --git a/src/State/Common.hs b/src/State/Common.hs --- a/src/State/Common.hs +++ b/src/State/Common.hs @@ -17,7 +17,8 @@ import Lens.Micro.Platform import System.Hclip (setClipboard, ClipboardException(..)) -import Network.Mattermost +import Network.Mattermost.Endpoints +import Network.Mattermost.Types import Network.Mattermost.Lenses import Network.Mattermost.Exceptions @@ -38,8 +39,9 @@ tryMM act onSuccess = do result <- liftIO $ try act case result of - Left (MattermostServerError msg) -> return $ postErrorMessage msg - Right value -> liftIO $ onSuccess value + Left (MattermostError { mattermostErrorMessage = msg }) -> + return $ postErrorMessage msg + Right value -> liftIO $ onSuccess value -- * Background Computation @@ -234,7 +236,7 @@ session <- use (csResources.crSession) host <- use (csResources.crConn.cdHostnameL) F.forM_ (p^.postFileIdsL) $ \fId -> doAsyncWith Normal $ do - info <- mmGetFileInfo session fId + info <- mmGetMetadataForFile fId session let scheme = "https://" attUrl = scheme <> host <> urlForFile fId attachment = mkAttachment (fileInfoName info) attUrl fId @@ -284,7 +286,7 @@ asyncFetchReactionsForPost cId p | not (p^.postHasReactionsL) = return () | otherwise = doAsyncChannelMM Normal cId - (\s t c -> mmGetReactionsForPost s t c (p^.postIdL)) + (\s _ _ -> fmap F.toList (mmGetReactionsForPost (p^.postIdL) s)) addReactions addReactions :: ChannelId -> [Reaction] -> MH () @@ -317,11 +319,3 @@ postErrorMessage errMsg Right () -> return () - -loadAllUsers :: Session -> IO (HM.HashMap UserId User) -loadAllUsers session = go HM.empty 0 - where go users n = do - newUsers <- mmGetUsers session (n * 50) 50 - if HM.null newUsers - then return users - else go (newUsers <> users) (n+1) diff --git a/src/State/Editing.hs b/src/State/Editing.hs --- a/src/State/Editing.hs +++ b/src/State/Editing.hs @@ -1,4 +1,5 @@ {-# LANGUAGE MultiWayIf #-} +{-#LANGUAGE RecordWildCards #-} module State.Editing where @@ -9,6 +10,8 @@ import Brick.Widgets.Edit (applyEdit) import qualified Codec.Binary.UTF8.Generic as UTF8 import Control.Arrow +import qualified Control.Concurrent.STM as STM +import Control.Monad (when) import Control.Monad.IO.Class (liftIO) import qualified Data.ByteString as BS import Data.Monoid ((<>)) @@ -17,6 +20,7 @@ import qualified Data.Text.Encoding as T import qualified Data.Text.Zipper as Z import qualified Data.Text.Zipper.Generic.Words as Z +import Data.Time (getCurrentTime) import Graphics.Vty (Event(..), Key(..), Modifier(..)) import Lens.Micro.Platform import qualified System.Environment as Sys @@ -28,9 +32,12 @@ import Config import Types +import Events.Keybindings import State.Common +import Network.Mattermost.Types (Post(..)) + startMultilineEditing :: MH () startMultilineEditing = csEditState.cedMultiline .= True @@ -90,59 +97,66 @@ editingKeybindings :: [Keybinding] editingKeybindings = - [ KB "Transpose the final two characters" + let kb desc ev mote = KB desc ev mote Nothing in + map withUserTypingAction + [ kb "Transpose the final two characters" (EvKey (KChar 't') [MCtrl]) $ do csEditState.cedEditor %= applyEdit Z.transposeChars - , KB "Go to the start of the current line" + , kb "Go to the start of the current line" (EvKey (KChar 'a') [MCtrl]) $ do csEditState.cedEditor %= applyEdit Z.gotoBOL - , KB "Go to the end of the current line" + , kb "Go to the end of the current line" (EvKey (KChar 'e') [MCtrl]) $ do csEditState.cedEditor %= applyEdit Z.gotoEOL - , KB "Delete the character at the cursor" + , kb "Delete the character at the cursor" (EvKey (KChar 'd') [MCtrl]) $ do csEditState.cedEditor %= applyEdit Z.deleteChar - , KB "Delete from the cursor to the start of the current line" + , kb "Delete from the cursor to the start of the current line" (EvKey (KChar 'u') [MCtrl]) $ do csEditState.cedEditor %= applyEdit Z.killToBOL - , KB "Move one character to the right" + , kb "Move one character to the right" (EvKey (KChar 'f') [MCtrl]) $ do csEditState.cedEditor %= applyEdit Z.moveRight - , KB "Move one character to the left" + , kb "Move one character to the left" (EvKey (KChar 'b') [MCtrl]) $ do csEditState.cedEditor %= applyEdit Z.moveLeft - , KB "Move one word to the right" + , kb "Move one word to the right" (EvKey (KChar 'f') [MMeta]) $ do csEditState.cedEditor %= applyEdit Z.moveWordRight - , KB "Move one word to the left" + , kb "Move one word to the left" (EvKey (KChar 'b') [MMeta]) $ do csEditState.cedEditor %= applyEdit Z.moveWordLeft - , KB "Delete the word to the left of the cursor" - (EvKey (KBS) [MMeta]) $ do + , kb "Delete the word to the left of the cursor" + (EvKey KBS [MMeta]) $ do csEditState.cedEditor %= applyEdit Z.deletePrevWord - , KB "Delete the word to the left of the cursor" + , kb "Delete the word to the left of the cursor" (EvKey (KChar 'w') [MCtrl]) $ do csEditState.cedEditor %= applyEdit Z.deletePrevWord - , KB "Delete the word to the right of the cursor" + , kb "Delete the word to the right of the cursor" (EvKey (KChar 'd') [MMeta]) $ do csEditState.cedEditor %= applyEdit Z.deleteWord - , KB "Move the cursor to the beginning of the input" + , kb "Move the cursor to the beginning of the input" (EvKey KHome []) $ do csEditState.cedEditor %= applyEdit gotoHome - , KB "Move the cursor to the end of the input" + , kb "Move the cursor to the end of the input" (EvKey KEnd []) $ do csEditState.cedEditor %= applyEdit gotoEnd - , KB "Kill the line to the right of the current position and copy it" + , kb "Kill the line to the right of the current position and copy it" (EvKey (KChar 'k') [MCtrl]) $ do z <- use (csEditState.cedEditor.editContentsL) let restOfLine = Z.currentLine (Z.killToBOL z) csEditState.cedYankBuffer .= restOfLine csEditState.cedEditor %= applyEdit Z.killToEOL - , KB "Paste the current buffer contents at the cursor" + , kb "Paste the current buffer contents at the cursor" (EvKey (KChar 'y') [MCtrl]) $ do buf <- use (csEditState.cedYankBuffer) csEditState.cedEditor %= applyEdit (Z.insertMany buf) ] + where + withUserTypingAction (KB {..}) = + KB kbDescription kbEvent + (kbAction >> sendUserTypingAction) + kbBindingInfo handleEditingInput :: Event -> MH () handleEditingInput e = do @@ -180,7 +194,9 @@ EvKey (KChar ch) [] | editingPermitted st && smartBacktick && ch `elem` smartChars -> -- Smart char insertion: - let doInsertChar = csEditState.cedEditor %= applyEdit (Z.insertChar ch) + let doInsertChar = do + csEditState.cedEditor %= applyEdit (Z.insertChar ch) + sendUserTypingAction in if | (editorEmpty $ st^.csEditState.cedEditor) || ((cursorAtChar ' ' (applyEdit Z.moveLeft $ st^.csEditState.cedEditor)) && (cursorIsAtEnd $ st^.csEditState.cedEditor)) -> @@ -190,12 +206,31 @@ csEditState.cedEditor %= applyEdit Z.moveRight | otherwise -> doInsertChar - _ | editingPermitted st -> mhHandleEventLensed (csEditState.cedEditor) handleEditorEvent e + _ | editingPermitted st -> do + mhHandleEventLensed (csEditState.cedEditor) handleEditorEvent e + sendUserTypingAction | otherwise -> return () csEditState.cedCurrentCompletion .= Nothing liftIO $ resetSpellCheckTimer $ st^.csEditState + +-- | Send the user_typing action to the server asynchronously, over the connected websocket. +-- | If the websocket is not connected, drop the action silently. +sendUserTypingAction :: MH () +sendUserTypingAction = do + st <- use id + when (configShowTypingIndicator (st^.csResources.crConfiguration)) $ + case st^.csConnectionStatus of + Connected -> do + let pId = case st^.csEditState.cedEditMode of + Replying _ post -> Just $ postId post + _ -> Nothing + liftIO $ do + now <- getCurrentTime + let action = UserTyping now (st^.csCurrentChannelId) pId + STM.atomically $ STM.writeTChan (st^.csResources.crWebsocketActionChan) action + Disconnected -> return () -- Kick off an async request to the spell checker for the current editor -- contents. diff --git a/src/State/PostListOverlay.hs b/src/State/PostListOverlay.hs --- a/src/State/PostListOverlay.hs +++ b/src/State/PostListOverlay.hs @@ -2,8 +2,8 @@ import Data.Text (Text) import Lens.Micro.Platform -import Network.Mattermost -import Network.Mattermost.Lenses +import Network.Mattermost.Endpoints +import Network.Mattermost.Types import State import State.Common @@ -25,14 +25,12 @@ csPostListOverlay.postListSelected .= Nothing csMode .= Main --- | Create a PostListOverlay with flagged messages from the --- server. +-- | Create a PostListOverlay with flagged messages from the server. enterFlaggedPostListMode :: MH () enterFlaggedPostListMode = do session <- use (csResources.crSession) - uId <- use (csMe.userIdL) doAsyncWith Preempt $ do - posts <- mmGetFlaggedPosts session uId + posts <- mmGetListOfFlaggedPosts UserMe defaultFlaggedPostsQuery session return $ do messages <- messagesFromPosts posts enterPostListMode PostListFlagged messages @@ -45,7 +43,7 @@ tId <- teamId <$> use csMyTeam enterPostListMode (PostListSearch terms True) noMessages doAsyncWith Preempt $ do - posts <- mmSearchPosts session tId terms False + posts <- mmSearchForTeamPosts tId (SearchPosts terms False) session return $ do messages <- messagesFromPosts posts enterPostListMode (PostListSearch terms False) messages diff --git a/src/State/Setup.hs b/src/State/Setup.hs --- a/src/State/Setup.hs +++ b/src/State/Setup.hs @@ -10,7 +10,7 @@ import Brick.BChan import Brick.Themes (themeToAttrMap, loadCustomizations) import qualified Control.Concurrent.STM as STM -import Control.Concurrent.MVar (newEmptyMVar, putMVar) +import Control.Concurrent.MVar (newMVar) import Control.Exception (catch) import Control.Monad (forM, when) import Data.Monoid ((<>)) @@ -19,22 +19,24 @@ import Data.Maybe (listToMaybe, fromMaybe, fromJust, isNothing) import qualified Data.Sequence as Seq import qualified Data.Text as T -import Data.Time.LocalTime (getCurrentTimeZone) import Lens.Micro.Platform import System.Exit (exitFailure) import System.FilePath ((), isRelative, dropFileName) import System.IO (Handle) -import Network.Mattermost +import Network.Mattermost.Endpoints +import Network.Mattermost.Types import Network.Mattermost.Logging (mmLoggerDebug) import Config import InputHistory import Login +import LastRunState import State (updateMessageFlag) import State.Common import TeamSelect import Themes +import TimeUtils (lookupLocalTimeZone) import State.Setup.Threads import Types import Types.Channels @@ -47,11 +49,21 @@ , flaggedPostStatus fp ] -setupState :: Maybe Handle -> Config -> RequestChan -> BChan MHEvent -> IO ChatState -setupState logFile config requestChan eventChan = do +incompleteCredentials :: Config -> ConnectionInfo +incompleteCredentials config = ConnectionInfo hStr (configPort config) uStr pStr + where + hStr = maybe "" id $ configHost config + uStr = maybe "" id $ configUser config + pStr = case configPass config of + Just (PasswordString s) -> s + _ -> "" + + +setupState :: Maybe Handle -> Config -> IO ChatState +setupState logFile initialConfig = do -- If we don't have enough credentials, ask for them. - connInfo <- case getCredentials config of - Nothing -> interactiveGatherCredentials config Nothing + connInfo <- case getCredentials initialConfig of + Nothing -> interactiveGatherCredentials (incompleteCredentials initialConfig) Nothing Just connInfo -> return connInfo let setLogger = case logFile of @@ -66,65 +78,65 @@ -- always try HTTPS first, and then, if the -- configuration option is there, try falling back to -- HTTP. - if (configUnsafeUseHTTP config) - then initConnectionDataInsecure (ciHostname cInfo) - (fromIntegral (ciPort cInfo)) - else initConnectionData (ciHostname cInfo) - (fromIntegral (ciPort cInfo)) + if (configUnsafeUseHTTP initialConfig) + then initConnectionDataInsecure (cInfo^.ciHostname) + (fromIntegral (cInfo^.ciPort)) + else initConnectionData (cInfo^.ciHostname) + (fromIntegral (cInfo^.ciPort)) - let login = Login { username = ciUsername cInfo - , password = ciPassword cInfo + let login = Login { username = cInfo^.ciUsername + , password = cInfo^.ciPassword } result <- (Right <$> mmLogin cd login) `catch` (\e -> return $ Left $ ResolveError e) `catch` (\e -> return $ Left $ ConnectError e) `catch` (\e -> return $ Left $ OtherAuthError e) - -- Update the config with the entered settings so we can let the - -- user adjust if something went wrong rather than enter them - -- all again. - let modifiedConfig = - config { configUser = Just $ ciUsername cInfo - , configPass = Just $ PasswordString $ ciPassword cInfo - , configPort = ciPort cInfo - , configHost = Just $ ciHostname cInfo - } + -- Update the config with the entered settings so that later, + -- when we offer the option of saving the entered credentials to + -- disk, we can do so with an updated config. + let config = + initialConfig { configUser = Just $ cInfo^.ciUsername + , configPass = Just $ PasswordString $ cInfo^.ciPassword + , configPort = cInfo^.ciPort + , configHost = Just $ cInfo^.ciHostname + } case result of Right (Right (sess, user)) -> - return (sess, user, cd) + return (sess, user, cd, config) Right (Left e) -> - interactiveGatherCredentials modifiedConfig (Just $ LoginError e) >>= + interactiveGatherCredentials cInfo (Just $ LoginError e) >>= loginLoop Left e -> - interactiveGatherCredentials modifiedConfig (Just e) >>= + interactiveGatherCredentials cInfo (Just e) >>= loginLoop - (session, myUser, cd) <- loginLoop connInfo + (session, myUser, cd, config) <- loginLoop connInfo - initialLoad <- mmGetInitialLoad session - when (Seq.null $ initialLoadTeams initialLoad) $ do + teams <- mmGetUsersTeams UserMe session + when (Seq.null teams) $ do putStrLn "Error: your account is not a member of any teams" exitFailure myTeam <- case configTeam config of Nothing -> do - interactiveTeamSelection $ F.toList $ initialLoadTeams initialLoad + interactiveTeamSelection $ F.toList teams Just tName -> do - let matchingTeam = listToMaybe $ filter matches $ F.toList $ initialLoadTeams initialLoad + let matchingTeam = listToMaybe $ filter matches $ F.toList teams matches t = teamName t == tName case matchingTeam of - Nothing -> interactiveTeamSelection (F.toList (initialLoadTeams initialLoad)) + Nothing -> interactiveTeamSelection (F.toList teams) Just t -> return t - quitCondition <- newEmptyMVar + userStatusLock <- newMVar () - userStatusLock <- newEmptyMVar - putMVar userStatusLock () + userIdSet <- STM.atomically $ STM.newTVar mempty - slc <- STM.atomically STM.newTChan + slc <- STM.newTChanIO + wac <- STM.newTChanIO - prefs <- mmGetMyPreferences session + prefs <- mmGetUsersPreferences UserMe session let themeName = case configTheme config of Nothing -> internalThemeName defaultTheme @@ -152,9 +164,11 @@ exitFailure Right t -> return t + requestChan <- STM.atomically STM.newTChan + eventChan <- newBChan 25 + let cr = ChatResources session cd requestChan eventChan - slc (themeToAttrMap custTheme) quitCondition - userStatusLock config mempty prefs + slc wac (themeToAttrMap custTheme) userStatusLock userIdSet config mempty prefs initializeState cr myTeam myUser @@ -164,13 +178,27 @@ requestChan = cr^.crRequestQueue myTeamId = getId myTeam + -- Create a predicate to find the last selected channel by reading the + -- run state file. If unable to read or decode or validate the file, this + -- predicate is just `isTownSquare`. + isLastSelectedChannel <- do + result <- readLastRunState $ teamId myTeam + case result of + Right lrs | isValidLastRunState cr myUser lrs -> return $ \c -> + channelId c == lrs^.lrsSelectedChannelId + _ -> return isTownSquare + -- Get all channels, but filter down to just the one we want to start -- in. We get all, rather than requesting by name or ID, because - -- we don't know whether the server will give us a last-viewed - -- preference, and when it doesn't, we need to look for Town Square - -- by name. Even this is ultimately not entirely correct since Town - -- Square can be renamed! - chans <- Seq.filter isTownSquare <$> mmGetChannels session myTeamId + -- we don't know whether the server will give us a last-viewed preference. + -- We first try to find a channel matching with the last selected channel ID, + -- failing which we look for the Town Square channel by name. + -- This is not entirely correct since the Town Square channel can be renamed! + userChans <- mmGetChannelsForUser UserMe myTeamId session + let lastSelectedChans = Seq.filter isLastSelectedChannel userChans + chans = if Seq.null lastSelectedChans + then Seq.filter isTownSquare userChans + else lastSelectedChans -- Since the only channel we are dealing with is by construction the -- last channel, we don't have to consider other cases here: @@ -179,23 +207,37 @@ state = ChanInitialSelect return (getId c, cChannel) - tz <- getCurrentTimeZone + tz <- lookupLocalTimeZone hist <- do result <- readHistory case result of Left _ -> return newHistory Right h -> return h + -------------------------------------------------------------------- -- Start background worker threads: + -- + -- * Main async queue worker thread + startAsyncWorkerThread (cr^.crConfiguration) (cr^.crRequestQueue) (cr^.crEventQueue) + -- * User status refresher - startUserRefreshThread (cr^.crUserStatusLock) session requestChan + startUserRefreshThread (cr^.crUserIdSet) (cr^.crUserStatusLock) session requestChan + + -- * Refresher for users who are typing currently + when (configShowTypingIndicator (cr^.crConfiguration)) $ + startTypingUsersRefreshThread requestChan + -- * Timezone change monitor startTimezoneMonitorThread tz requestChan + -- * Subprocess logger startSubprocessLoggerThread (cr^.crSubprocessLog) requestChan + -- * Spell checker and spell check timer, if configured spResult <- maybeStartSpellChecker (cr^.crConfiguration) (cr^.crEventQueue) + -- End thread startup ---------------------------------------------- + let chanNames = mkChanNames myUser mempty chans chanIds = [ (chanNames ^. cnToChanId) HM.! i | i <- chanNames ^. cnChans ] @@ -205,4 +247,8 @@ & csNames .~ chanNames loadFlaggedMessages (cr^.crPreferences) st + + -- Trigger an initial websocket refresh + writeBChan (cr^.crEventQueue) RefreshWebsocketEvent + return st diff --git a/src/State/Setup/Threads.hs b/src/State/Setup/Threads.hs --- a/src/State/Setup/Threads.hs +++ b/src/State/Setup/Threads.hs @@ -1,5 +1,6 @@ module State.Setup.Threads ( startUserRefreshThread + , startTypingUsersRefreshThread , updateUserStatuses , startSubprocessLoggerThread , startTimezoneMonitorThread @@ -17,11 +18,16 @@ import Control.Concurrent.STM.Delay import Control.Exception (SomeException, try, finally) import Control.Monad (forever, when, void) +import Control.Monad.IO.Class (liftIO) import Data.List (isInfixOf) +import qualified Data.Foldable as F +import qualified Data.HashMap.Strict as HM +import qualified Data.Sequence as Seq import qualified Data.Text as T import Data.Maybe (catMaybes) import Data.Monoid ((<>)) -import Data.Time.LocalTime ( TimeZone(..), getCurrentTimeZone ) +import Data.Time (getCurrentTime, addUTCTime) +import Data.Time.LocalTime.TimeZone.Series (TimeZoneSeries) import Lens.Micro.Platform import System.Exit (ExitCode(ExitSuccess)) import System.IO (hPutStrLn, hFlush) @@ -29,39 +35,62 @@ import System.Directory (getTemporaryDirectory) import Text.Aspell (Aspell, AspellOption(..), startAspell) -import Network.Mattermost +import Network.Mattermost.Endpoints +import Network.Mattermost.Types +import Constants import State.Common import State.Editing (requestSpellCheck) +import TimeUtils (lookupLocalTimeZone) import Types import Types.Users +import Types.Channels -updateUserStatuses :: MVar () -> Session -> IO (MH ()) -updateUserStatuses lock session = do +updateUserStatuses :: STM.TVar (Seq.Seq UserId) -> MVar () -> Session -> IO (MH ()) +updateUserStatuses usersVar lock session = do lockResult <- tryTakeMVar lock + users <- STM.atomically $ STM.readTVar usersVar case lockResult of - Nothing -> return $ return () - Just () -> do - statusMap <- mmGetStatuses session `finally` putMVar lock () + Just () | not (F.null users) -> do + statuses <- mmGetUserStatusByIds users session `finally` putMVar lock () return $ do - let setStatus u = u & uiStatus .~ (newsts u) + let statusMap = HM.fromList [ (statusUserId s, statusStatus s) | s <- F.toList statuses ] + setStatus u = u & uiStatus .~ (newsts u) newsts u = (statusMap^.at(u^.uiId) & _Just %~ statusFromText) ^. non Offline csUsers . mapped %= setStatus + Just () -> putMVar lock () >> return (return ()) + _ -> return $ return () -startUserRefreshThread :: MVar () -> Session -> RequestChan -> IO () -startUserRefreshThread lock session requestChan = void $ forkIO $ forever refresh +startUserRefreshThread :: STM.TVar (Seq.Seq UserId) -> MVar () -> Session -> RequestChan -> IO () +startUserRefreshThread usersVar lock session requestChan = void $ forkIO $ forever refresh where seconds = (* (1000 * 1000)) userRefreshInterval = 30 refresh = do STM.atomically $ STM.writeTChan requestChan $ do - rs <- try $ updateUserStatuses lock session + rs <- try $ updateUserStatuses usersVar lock session case rs of Left (_ :: SomeException) -> return (return ()) Right upd -> return upd threadDelay (seconds userRefreshInterval) +-- This thread refreshes the map of typing users every second, forever, +-- to expire users who have stopped typing. Expiry time is 3 seconds. +startTypingUsersRefreshThread :: RequestChan -> IO () +startTypingUsersRefreshThread requestChan = void $ forkIO $ forever refresh + where + seconds = (* (1000 * 1000)) + refreshIntervalMicros = ceiling $ seconds $ userTypingExpiryInterval / 2 + refresh = do + STM.atomically $ STM.writeTChan requestChan $ return $ do + now <- liftIO getCurrentTime + let expiry = addUTCTime (- userTypingExpiryInterval) now + let expireUsers c = c & ccInfo.cdTypingUsers %~ expireTypingUsers expiry + csChannels . mapped %= expireUsers + + threadDelay refreshIntervalMicros + startSubprocessLoggerThread :: STM.TChan ProgramOutput -> RequestChan -> IO () startSubprocessLoggerThread logChan requestChan = do let logMonitor mPair = do @@ -105,7 +134,7 @@ void $ forkIO $ logMonitor Nothing -startTimezoneMonitorThread :: TimeZone -> RequestChan -> IO () +startTimezoneMonitorThread :: TimeZoneSeries -> RequestChan -> IO () startTimezoneMonitorThread tz requestChan = do -- Start the timezone monitor thread let timezoneMonitorSleepInterval = minutes 5 @@ -114,7 +143,7 @@ timezoneMonitor prevTz = do threadDelay timezoneMonitorSleepInterval - newTz <- getCurrentTimeZone + newTz <- lookupLocalTimeZone when (newTz /= prevTz) $ STM.atomically $ STM.writeTChan requestChan $ do return $ timeZone .= newTz @@ -122,6 +151,7 @@ timezoneMonitor newTz void $ forkIO (timezoneMonitor tz) + maybeStartSpellChecker :: Config -> BChan MHEvent -> IO (Maybe (Aspell, IO ())) maybeStartSpellChecker config eventQueue = do diff --git a/src/TeamSelect.hs b/src/TeamSelect.hs --- a/src/TeamSelect.hs +++ b/src/TeamSelect.hs @@ -14,7 +14,7 @@ import Graphics.Vty import System.Exit (exitSuccess) -import Network.Mattermost +import Network.Mattermost.Types import Markdown diff --git a/src/Themes.hs b/src/Themes.hs --- a/src/Themes.hs +++ b/src/Themes.hs @@ -47,7 +47,6 @@ -- * Username formatting , colorUsername - , attrForUsername ) where import Prelude () @@ -66,8 +65,6 @@ import qualified Skylighting as Sky import Skylighting (TokenType(..)) -import Types (userSigil) - helpAttr :: AttrName helpAttr = "help" @@ -304,17 +301,10 @@ usernameAttr :: Int -> AttrName usernameAttr i = "username" <> (attrName $ show i) -colorUsername :: T.Text -> Widget a -colorUsername s = withDefAttr (attrForUsername s) $ txt s - -attrForUsername :: T.Text -> AttrName -attrForUsername s - | (T.singleton userSigil) `T.isPrefixOf` s || - "+" `T.isPrefixOf` s || - "-" `T.isPrefixOf` s || - " " `T.isPrefixOf` s - = usernameAttr $ hash (T.tail s) `mod` (length usernameColors) - | otherwise = usernameAttr $ hash s `mod` (length usernameColors) +colorUsername :: T.Text -> T.Text -> Widget a +colorUsername username display = + withDefAttr (usernameAttr h) $ txt (display) + where h = hash username `mod` length usernameColors usernameColors :: [Attr] usernameColors = diff --git a/src/TimeUtils.hs b/src/TimeUtils.hs new file mode 100644 --- /dev/null +++ b/src/TimeUtils.hs @@ -0,0 +1,72 @@ +module TimeUtils + ( lookupLocalTimeZone + , startOfDay + , justAfter, justBefore + , asLocalTime + , localTimeText + , originTime + ) + where + +import qualified Data.Text as T +import Data.Time.Clock (UTCTime(..)) +import Data.Time.Format (formatTime, defaultTimeLocale) +import Data.Time.LocalTime (LocalTime(..), TimeOfDay(..)) +import Data.Time.LocalTime.TimeZone.Olson (getTimeZoneSeriesFromOlsonFile) +import Data.Time.LocalTime.TimeZone.Series (TimeZoneSeries + , localTimeToUTC' + , utcToLocalTime') +import Network.Mattermost.Types (ServerTime(..)) + + +-- | Get the timezone series that should be used for converting UTC +-- times into local times with appropriate DST adjustments. +lookupLocalTimeZone :: IO TimeZoneSeries +lookupLocalTimeZone = getTimeZoneSeriesFromOlsonFile "/etc/localtime" + + +-- | Sometimes it is convenient to render a divider between messages; +-- the 'justAfter' function can be used to get a time that is after +-- the input time but by such a small increment that there is unlikely +-- to be anything between (or at) the result. Adding the divider +-- using this timestamp value allows the general sorting based on +-- timestamps to operate normally (whereas a type-match for a +-- non-timestamp-entry in the sort operation would be considerably +-- more complex). +justAfter :: ServerTime -> ServerTime +justAfter = ServerTime . justAfterUTC . withServerTime + where justAfterUTC time = let UTCTime d t = time in UTCTime d (succ t) + + +-- | Obtain a time value that is just moments before the input time; +-- see the comment for the 'justAfter' function for more details. +justBefore :: ServerTime -> ServerTime +justBefore = ServerTime . justBeforeUTC . withServerTime + where justBeforeUTC time = let UTCTime d t = time in UTCTime d (pred t) + + +-- | The timestamp for the start of the day associated with the input +-- timestamp. If timezone information is supplied, then the returned +-- value will correspond to when the day started in that timezone; +-- otherwise it is the start of the day in a timezone aligned with +-- UTC. +startOfDay :: Maybe TimeZoneSeries -> UTCTime -> UTCTime +startOfDay Nothing time = let UTCTime d _ = time in UTCTime d 0 +startOfDay (Just tz) time = let lt = utcToLocalTime' tz time + ls = LocalTime (localDay lt) (TimeOfDay 0 0 0) + in localTimeToUTC' tz ls + + +-- | Convert a UTC time value to a local time. +asLocalTime :: TimeZoneSeries -> UTCTime -> LocalTime +asLocalTime = utcToLocalTime' + + +-- | Local time in displayable format +localTimeText :: T.Text -> LocalTime -> T.Text +localTimeText fmt time = T.pack $ formatTime defaultTimeLocale (T.unpack fmt) time + + +-- | Provides a time value that can be used when there are no other times available +originTime :: UTCTime +originTime = UTCTime (toEnum 0) 0 diff --git a/src/Types.hs b/src/Types.hs --- a/src/Types.hs +++ b/src/Types.hs @@ -13,6 +13,10 @@ , Name(..) , ChannelSelectMatch(..) , ConnectionInfo(..) + , ciHostname + , ciPort + , ciUsername + , ciPassword , Config(..) , HelpScreen(..) , PasswordSource(..) @@ -98,20 +102,20 @@ , crTheme , crSession , crSubprocessLog + , crWebsocketActionChan , crRequestQueue - , crQuitCondition , crUserStatusLock + , crUserIdSet , crFlaggedPosts , crConn , crConfiguration + , WebsocketAction(..) + , Cmd(..) , commandName , CmdArgs(..) - , Keybinding(..) - , lookupKeybinding - , MH , runMHEvent , mh @@ -121,6 +125,7 @@ , requestQuit , clientPostToMessage , getMessageForPostId + , getParentMessage , resetSpellCheckTimer , withChannel , withChannelOrDefault @@ -133,6 +138,11 @@ , userSigil , normalChannelSigil + + , HighlightSet(..) + , UserSet + , ChannelSet + , getHighlightSet ) where @@ -151,23 +161,21 @@ import qualified Control.Monad.State as St import qualified Data.Foldable as F import qualified Data.Sequence as Seq -import qualified Data.Set as S import Data.HashMap.Strict (HashMap) -import Data.Time.Clock (UTCTime) -import Data.Time.LocalTime (TimeZone) +import Data.Time (UTCTime) +import Data.Time.LocalTime.TimeZone.Series (TimeZoneSeries) import qualified Data.HashMap.Strict as HM import Data.List (sort, partition, sortBy) import Data.Maybe import Data.Monoid -import Data.Set (Set) -import qualified Graphics.Vty as Vty +import qualified Data.Set as Set import Lens.Micro.Platform ( at, makeLenses, lens, (&), (^.), (%~), (.~), (^?!) - , _Just, Traversal', preuse ) -import Network.Mattermost -import Network.Mattermost.Types (ChannelId(..)) + , _Just, Traversal', preuse, (^..), folded, to ) +import Network.Mattermost (ConnectionData) import Network.Mattermost.Exceptions import Network.Mattermost.Lenses -import Network.Mattermost.WebSocket +import Network.Mattermost.Types +import Network.Mattermost.WebSocket (WebsocketEvent) import Network.Connection (HostNotResolved, HostCannotConnect) import qualified Data.Text as T import System.Exit (ExitCode) @@ -178,6 +186,7 @@ import InputHistory import Types.Channels +import Types.KeyEvents import Types.Posts import Types.Messages import Types.Users @@ -194,27 +203,29 @@ -- | These are all the values that can be read in our configuration -- file. data Config = Config - { configUser :: Maybe T.Text - , configHost :: Maybe T.Text - , configTeam :: Maybe T.Text - , configPort :: Int - , configPass :: Maybe PasswordSource - , configTimeFormat :: Maybe T.Text - , configDateFormat :: Maybe T.Text - , configTheme :: Maybe T.Text - , configThemeCustomizationFile :: Maybe T.Text - , configSmartBacktick :: Bool - , configURLOpenCommand :: Maybe T.Text + { configUser :: Maybe T.Text + , configHost :: Maybe T.Text + , configTeam :: Maybe T.Text + , configPort :: Int + , configPass :: Maybe PasswordSource + , configTimeFormat :: Maybe T.Text + , configDateFormat :: Maybe T.Text + , configTheme :: Maybe T.Text + , configThemeCustomizationFile :: Maybe T.Text + , configSmartBacktick :: Bool + , configURLOpenCommand :: Maybe T.Text , configURLOpenCommandInteractive :: Bool - , configActivityBell :: Bool - , configShowBackground :: BackgroundInfo - , configShowMessagePreview :: Bool - , configEnableAspell :: Bool - , configAspellDictionary :: Maybe T.Text - , configUnsafeUseHTTP :: Bool - , configChannelListWidth :: Int - , configShowOlderEdits :: Bool - , configAbsPath :: Maybe FilePath + , configActivityBell :: Bool + , configShowBackground :: BackgroundInfo + , configShowMessagePreview :: Bool + , configEnableAspell :: Bool + , configAspellDictionary :: Maybe T.Text + , configUnsafeUseHTTP :: Bool + , configChannelListWidth :: Int + , configShowOlderEdits :: Bool + , configShowTypingIndicator :: Bool + , configAbsPath :: Maybe FilePath + , configUserKeys :: KeyConfig } deriving (Eq, Show) data BackgroundInfo = Disabled | Active | ActiveCount deriving (Eq, Show) @@ -270,6 +281,7 @@ | HelpText | ScriptHelpText | ThemeHelpText + | KeybindingHelpText | ChannelSelectString | CompletionAlternatives | JoinChannelList @@ -290,12 +302,14 @@ -- | Our 'ConnectionInfo' contains exactly as much information as is -- necessary to start a connection with a Mattermost server data ConnectionInfo = - ConnectionInfo { ciHostname :: T.Text - , ciPort :: Int - , ciUsername :: T.Text - , ciPassword :: T.Text + ConnectionInfo { _ciHostname :: T.Text + , _ciPort :: Int + , _ciUsername :: T.Text + , _ciPassword :: T.Text } +makeLenses ''ConnectionInfo + -- | We want to continue referring to posts by their IDs, but we don't want to -- have to synthesize new valid IDs for messages from the client -- itself (like error messages or informative client responses). To @@ -308,7 +322,7 @@ -- | For representing links to things in the 'open links' view data LinkChoice = LinkChoice - { _linkTime :: UTCTime + { _linkTime :: ServerTime , _linkUser :: T.Text , _linkName :: T.Text , _linkURL :: T.Text @@ -318,11 +332,11 @@ makeLenses ''LinkChoice -- Sigils -normalChannelSigil :: Char -normalChannelSigil = '~' +normalChannelSigil :: T.Text +normalChannelSigil = "~" -userSigil :: Char -userSigil = '@' +userSigil :: T.Text +userSigil = "@" -- ** Channel-matching types @@ -360,17 +374,18 @@ -- limited to information that we read or set up -- prior to setting up the bulk of the application state. data ChatResources = ChatResources - { _crSession :: Session - , _crConn :: ConnectionData - , _crRequestQueue :: RequestChan - , _crEventQueue :: BChan MHEvent - , _crSubprocessLog :: STM.TChan ProgramOutput - , _crTheme :: AttrMap - , _crQuitCondition :: MVar () - , _crUserStatusLock :: MVar () - , _crConfiguration :: Config - , _crFlaggedPosts :: Set PostId - , _crPreferences :: Seq.Seq Preference + { _crSession :: Session + , _crConn :: ConnectionData + , _crRequestQueue :: RequestChan + , _crEventQueue :: BChan MHEvent + , _crSubprocessLog :: STM.TChan ProgramOutput + , _crWebsocketActionChan :: STM.TChan WebsocketAction + , _crTheme :: AttrMap + , _crUserStatusLock :: MVar () + , _crUserIdSet :: STM.TVar (Seq.Seq UserId) + , _crConfiguration :: Config + , _crFlaggedPosts :: Set.Set PostId + , _crPreferences :: Seq.Seq Preference } -- | The 'ChatEditState' value contains the editor widget itself @@ -388,7 +403,7 @@ , _cedCompletionAlternatives :: [T.Text] , _cedYankBuffer :: T.Text , _cedSpellChecker :: Maybe (Aspell, IO ()) - , _cedMisspellings :: S.Set T.Text + , _cedMisspellings :: Set.Set T.Text } data EditMode = @@ -425,6 +440,7 @@ = MainHelp | ScriptHelp | ThemeHelp + | KeybindingHelp deriving (Eq) -- | Help topics @@ -473,7 +489,7 @@ , _csChannels :: ClientChannels , _csPostMap :: HashMap PostId Message , _csUsers :: Users - , _timeZone :: TimeZone + , _timeZone :: TimeZoneSeries , _csEditState :: ChatEditState , _csMode :: Mode , _csShowMessagePreview :: Bool @@ -491,7 +507,7 @@ -> Zipper ChannelId -> User -> Team - -> TimeZone + -> TimeZoneSeries -> InputHistory -> Maybe (Aspell, IO ()) -> ChatState @@ -543,6 +559,13 @@ , _postListSelected :: Maybe PostId } +-- | Actions that can be sent on the websocket to the server. +data WebsocketAction = + UserTyping UTCTime ChannelId (Maybe PostId) -- ^ user typing in the input box + -- | GetStatuses + -- | GetStatusesByIds [UserId] + deriving (Read, Show, Eq, Ord) + -- * MH Monad -- | A value of type 'MH' @a@ represents a computation that can @@ -669,6 +692,12 @@ getMessageForPostId :: ChatState -> PostId -> Maybe Message getMessageForPostId st pId = st^.csPostMap.at(pId) +getParentMessage :: ChatState -> Message -> Maybe Message +getParentMessage st msg + | InReplyTo pId <- msg^.mInReplyToMsg + = st^.csPostMap.at(pId) + | otherwise = Nothing + getUsernameForUserId :: ChatState -> UserId -> Maybe T.Text getUsernameForUserId st uId = _uiName <$> findUserById uId (st^.csUsers) @@ -721,20 +750,6 @@ commandName :: Cmd -> T.Text commandName (Cmd name _ _ _ ) = name --- * Keybindings - --- | A 'Keybinding' represents a keybinding along with its --- implementation -data Keybinding = - KB { kbDescription :: T.Text - , kbEvent :: Vty.Event - , kbAction :: MH () - } - --- | Find a keybinding that matches a Vty Event -lookupKeybinding :: Vty.Event -> [Keybinding] -> Maybe Keybinding -lookupKeybinding e kbs = listToMaybe $ filter ((== e) . kbEvent) kbs - -- * Channel Updates and Notifications hasUnread :: ChatState -> ChannelId -> Bool @@ -769,3 +784,19 @@ LT | otherwise = (u1^.field) `compare` (u2^.field) + +-- * HighlightSet + +type UserSet = Set.Set T.Text +type ChannelSet = Set.Set T.Text + +data HighlightSet = HighlightSet + { hUserSet :: Set.Set T.Text + , hChannelSet :: Set.Set T.Text + } + +getHighlightSet :: ChatState -> HighlightSet +getHighlightSet st = HighlightSet + { hUserSet = Set.fromList (st^..csUsers.to allUsers.folded.uiName) + , hChannelSet = Set.fromList (st^..csChannels.folded.ccInfo.cdName) + } diff --git a/src/Types/Channels.hs b/src/Types/Channels.hs --- a/src/Types/Channels.hs +++ b/src/Types/Channels.hs @@ -15,8 +15,8 @@ , ccContents, ccInfo -- * Lenses created for accessing ChannelInfo fields , cdViewed, cdNewMessageIndicator, cdEditedMessageThreshold, cdUpdated - , cdName, cdHeader, cdType, cdCurrentState - , cdMentionCount + , cdName, cdHeader, cdPurpose, cdType, cdCurrentState + , cdMentionCount, cdTypingUsers -- * Lenses created for accessing ChannelContents fields , cdMessages -- * Creating ClientChannel objects @@ -39,6 +39,7 @@ , adjustUpdated , adjustEditedThreshold , updateNewMessageIndicator + , addChannelTypingUser -- * Notification settings , notifyPreference -- * Miscellaneous channel-related operations @@ -53,17 +54,19 @@ import Data.Time.Clock (UTCTime) import Lens.Micro.Platform import Network.Mattermost.Lenses hiding (Lens') -import Network.Mattermost.Types ( Channel(..), ChannelId - , ChannelWithData(..) +import Network.Mattermost.Types ( Channel(..), UserId, ChannelId + , ChannelMember(..) , Type(..) , Post , User(userNotifyProps) , ChannelNotifyProps , NotifyOption(..) , WithDefault(..) + , ServerTime , emptyChannelNotifyProps ) import Types.Messages (Messages, noMessages) +import Types.Users (TypingUsers, noTypingUsers, addTypingUser) -- * Channel representations @@ -84,28 +87,30 @@ data NewMessageIndicator = Hide - | NewPostsAfterServerTime UTCTime - | NewPostsStartingAt UTCTime + | NewPostsAfterServerTime ServerTime + | NewPostsStartingAt ServerTime deriving (Eq, Show) initialChannelInfo :: Channel -> ChannelInfo initialChannelInfo chan = let updated = chan ^. channelLastPostAtL - in ChannelInfo { _cdViewed = Nothing - , _cdNewMessageIndicator = Hide + in ChannelInfo { _cdViewed = Nothing + , _cdNewMessageIndicator = Hide , _cdEditedMessageThreshold = Nothing - , _cdMentionCount = 0 - , _cdUpdated = updated - , _cdName = preferredChannelName chan - , _cdHeader = chan^.channelHeaderL - , _cdType = chan^.channelTypeL - , _cdCurrentState = initialChannelState - , _cdNotifyProps = emptyChannelNotifyProps + , _cdMentionCount = 0 + , _cdUpdated = updated + , _cdName = preferredChannelName chan + , _cdHeader = chan^.channelHeaderL + , _cdPurpose = chan^.channelPurposeL + , _cdType = chan^.channelTypeL + , _cdCurrentState = initialChannelState + , _cdNotifyProps = emptyChannelNotifyProps + , _cdTypingUsers = noTypingUsers } -channelInfoFromChannelWithData :: ChannelWithData -> ChannelInfo -> ChannelInfo -channelInfoFromChannelWithData (ChannelWithData chan chanData) ci = - let viewed = chanData ^. channelDataLastViewedAtL +channelInfoFromChannelWithData :: Channel -> ChannelMember -> ChannelInfo -> ChannelInfo +channelInfoFromChannelWithData chan chanMember ci = + let viewed = chanMember ^. to channelMemberLastViewedAt updated = chan ^. channelLastPostAtL in ci { _cdViewed = Just viewed , _cdNewMessageIndicator = case _cdNewMessageIndicator ci of @@ -114,9 +119,10 @@ , _cdUpdated = updated , _cdName = preferredChannelName chan , _cdHeader = (chan^.channelHeaderL) + , _cdPurpose = (chan^.channelPurposeL) , _cdType = (chan^.channelTypeL) - , _cdMentionCount = chanData^.channelDataMentionCountL - , _cdNotifyProps = chanData^.channelDataNotifyPropsL + , _cdMentionCount = chanMember^.to channelMemberMentionCount + , _cdNotifyProps = chanMember^.to channelMemberNotifyProps } -- | The 'ChannelContents' is a wrapper for a list of @@ -218,26 +224,30 @@ -- | The 'ChannelInfo' record represents metadata -- about a channel data ChannelInfo = ChannelInfo - { _cdViewed :: Maybe UTCTime + { _cdViewed :: Maybe ServerTime -- ^ The last time we looked at a channel , _cdNewMessageIndicator :: NewMessageIndicator -- ^ The state of the channel's new message indicator. - , _cdEditedMessageThreshold :: Maybe UTCTime + , _cdEditedMessageThreshold :: Maybe ServerTime -- ^ The channel's edited message threshold. , _cdMentionCount :: Int -- ^ The current number of unread mentions - , _cdUpdated :: UTCTime + , _cdUpdated :: ServerTime -- ^ The last time a message showed up in the channel , _cdName :: T.Text -- ^ The name of the channel , _cdHeader :: T.Text -- ^ The header text of a channel + , _cdPurpose :: T.Text + -- ^ The stated purpose of the channel , _cdType :: Type -- ^ The type of a channel: public, private, or DM , _cdCurrentState :: ChannelState -- ^ The current state of the channel , _cdNotifyProps :: ChannelNotifyProps -- ^ The user's notification settings for this channel + , _cdTypingUsers :: TypingUsers + -- ^ The users who are currently typing in this channel } -- ** Channel-related Lenses @@ -287,7 +297,7 @@ findChannelById :: ChannelId -> ClientChannels -> Maybe ClientChannel findChannelById cId = HM.lookup cId . _ofChans --- | Extract a specific user from the collection and perform an +-- | Extract a specific channel from the collection and perform an -- endomorphism operation on it, then put it back into the collection. modifyChannelById :: ChannelId -> (ClientChannel -> ClientChannel) -> ClientChannels -> ClientChannels @@ -315,6 +325,10 @@ filteredChannels f cc = AllChannels . HM.fromList . filter f $ cc^.ofChans.to HM.toList +-- | Add user to the list of users in this channel who are currently typing. +addChannelTypingUser :: UserId -> UTCTime -> ClientChannel -> ClientChannel +addChannelTypingUser uId ts = ccInfo.cdTypingUsers %~ (addTypingUser uId ts) + -- | Clear the new message indicator for the specified channel clearNewMessageIndicator :: ClientChannel -> ClientChannel clearNewMessageIndicator c = c & ccInfo.cdNewMessageIndicator .~ Hide @@ -338,7 +352,7 @@ Nothing -> Just $ m^.postUpdateAtL ) -maxPostTimestamp :: Post -> UTCTime +maxPostTimestamp :: Post -> ServerTime maxPostTimestamp m = max (m^.postDeleteAtL . non (m^.postUpdateAtL)) (m^.postCreateAtL) updateNewMessageIndicator :: Post -> ClientChannel -> ClientChannel diff --git a/src/Types/DirectionalSeq.hs b/src/Types/DirectionalSeq.hs new file mode 100644 --- /dev/null +++ b/src/Types/DirectionalSeq.hs @@ -0,0 +1,36 @@ +{-# LANGUAGE DeriveFunctor #-} +{-# LANGUAGE DeriveFoldable #-} +{-# LANGUAGE DeriveTraversable #-} + +{- | These declarations allow the use of a DirectionalSeq, which is a + Seq that uses a phantom type to identify the ordering of the + elements in the sequence (Forward or Reverse). The constructors + are not exported from this module so that a DirectionalSeq can only + be constructed by the functions in this module. +-} + +module Types.DirectionalSeq where + + +import Data.Monoid () +import qualified Data.Sequence as Seq + + +data Chronological +data Retrograde +class SeqDirection a +instance SeqDirection Chronological +instance SeqDirection Retrograde + +data SeqDirection dir => DirectionalSeq dir a = + DSeq { dseq :: Seq.Seq a } + deriving (Show, Functor, Foldable, Traversable) + +instance SeqDirection a => Monoid (DirectionalSeq a e) where + mempty = DSeq mempty + mappend a b = DSeq $ mappend (dseq a) (dseq b) + +onDirectedSeq :: SeqDirection dir => (Seq.Seq a -> Seq.Seq b) + -> DirectionalSeq dir a -> DirectionalSeq dir b +onDirectedSeq f = DSeq . f . dseq + diff --git a/src/Types/KeyEvents.hs b/src/Types/KeyEvents.hs new file mode 100644 --- /dev/null +++ b/src/Types/KeyEvents.hs @@ -0,0 +1,293 @@ +module Types.KeyEvents + ( + -- * Types + KeyEvent(..) + , KeyConfig + , Binding(..) + , BindingState(..) + + -- * Data + , allEvents + + -- * Parsing and pretty-printing + , parseBinding + , parseBindingList + , ppBinding + , nonCharKeys + , eventToBinding + + -- * Key event name resolution + , keyEventFromName + , keyEventName + ) +where + +import qualified Data.Map.Strict as M +import qualified Data.Text as T +import qualified Graphics.Vty as Vty +import Text.Read (readMaybe) +import Data.Monoid ((<>)) + +-- | This enum represents all the possible key events a user might +-- want to use. +data KeyEvent + = VtyRefreshEvent + | ShowHelpEvent + | EnterSelectModeEvent + | ReplyRecentEvent + | ToggleMessagePreviewEvent + | InvokeEditorEvent + | EnterFastSelectModeEvent + | QuitEvent + | NextChannelEvent + | PrevChannelEvent + | NextUnreadChannelEvent + | LastChannelEvent + | EnterOpenURLModeEvent + | ClearUnreadEvent + | ToggleMultiLineEvent + | EnterFlaggedPostsEvent + + -- generic cancel + | CancelEvent + + -- channel-scroll-specific + | LoadMoreEvent + | OpenMessageURLEvent + + -- scrolling events---maybe rebindable? + | ScrollUpEvent + | ScrollDownEvent + | PageUpEvent + | PageDownEvent + | ScrollTopEvent + | ScrollBottomEvent + + -- select events---not the same as scrolling sometimes! + | SelectUpEvent + | SelectDownEvent + + | FlagMessageEvent + | YankMessageEvent + | DeleteMessageEvent + | EditMessageEvent + | ReplyMessageEvent + deriving (Eq, Show, Ord, Enum) + +allEvents :: [KeyEvent] +allEvents = + [ QuitEvent + , VtyRefreshEvent + , ClearUnreadEvent + + , ToggleMessagePreviewEvent + , InvokeEditorEvent + , ToggleMultiLineEvent + , CancelEvent + , ReplyRecentEvent + + , EnterFastSelectModeEvent + , NextChannelEvent + , PrevChannelEvent + , NextUnreadChannelEvent + , LastChannelEvent + + , EnterFlaggedPostsEvent + , ShowHelpEvent + , EnterSelectModeEvent + , EnterOpenURLModeEvent + + , LoadMoreEvent + , OpenMessageURLEvent + + , ScrollUpEvent + , ScrollDownEvent + , PageUpEvent + , PageDownEvent + , ScrollTopEvent + , ScrollBottomEvent + + , SelectUpEvent + , SelectDownEvent + + , FlagMessageEvent + , YankMessageEvent + , DeleteMessageEvent + , EditMessageEvent + , ReplyMessageEvent + ] + +eventToBinding :: Vty.Event -> Binding +eventToBinding (Vty.EvKey k mods) = Binding mods k +eventToBinding k = error $ "BUG: invalid keybinding " <> show k + +data Binding = Binding + { kbMods :: [Vty.Modifier] + , kbKey :: Vty.Key + } deriving (Eq, Show, Ord) + +data BindingState = + BindingList [Binding] + | Unbound + deriving (Show, Eq, Ord) + +type KeyConfig = M.Map KeyEvent BindingState + +parseBinding :: T.Text -> Either String Binding +parseBinding kb = go (T.splitOn "-" $ T.toLower kb) [] + where go [k] mods = do + key <- pKey k + return Binding { kbMods = mods, kbKey = key } + go (k:ks) mods = do + m <- case k of + "s" -> return Vty.MShift + "shift" -> return Vty.MShift + "m" -> return Vty.MMeta + "meta" -> return Vty.MMeta + "a" -> return Vty.MAlt + "alt" -> return Vty.MAlt + "c" -> return Vty.MCtrl + "ctrl" -> return Vty.MCtrl + "control" -> return Vty.MCtrl + _ -> Left ("Unknown modifier prefix: " ++ show k) + go ks (m:mods) + go [] _ = Left "Empty keybinding not allowed" + pKey "esc" = return Vty.KEsc + pKey "backspace" = return Vty.KBS + pKey "enter" = return Vty.KEnter + pKey "left" = return Vty.KLeft + pKey "right" = return Vty.KRight + pKey "up" = return Vty.KUp + pKey "down" = return Vty.KDown + pKey "upleft" = return Vty.KUpLeft + pKey "upright" = return Vty.KUpRight + pKey "downleft" = return Vty.KDownLeft + pKey "downright" = return Vty.KDownRight + pKey "center" = return Vty.KCenter + pKey "backtab" = return Vty.KBackTab + pKey "printscreen" = return Vty.KPrtScr + pKey "pause" = return Vty.KPause + pKey "insert" = return Vty.KIns + pKey "home" = return Vty.KHome + pKey "pgup" = return Vty.KPageUp + pKey "del" = return Vty.KDel + pKey "end" = return Vty.KEnd + pKey "pgdown" = return Vty.KPageDown + pKey "begin" = return Vty.KBegin + pKey "menu" = return Vty.KMenu + pKey "space" = return (Vty.KChar ' ') + pKey "tab" = return (Vty.KChar '\t') + pKey t + | Just (c, "") <- T.uncons t = + return (Vty.KChar c) + | Just n <- T.stripPrefix "f" t = + case readMaybe (T.unpack n) of + Nothing -> Left ("Unknown keybinding: " ++ show t) + Just i -> return (Vty.KFun i) + | otherwise = Left ("Unknown keybinding: " ++ show t) + +ppBinding :: Binding -> T.Text +ppBinding (Binding mods k) = + T.intercalate "-" $ (ppMod <$> mods) <> [ppKey k] + +ppKey :: Vty.Key -> T.Text +ppKey (Vty.KChar c) = ppChar c +ppKey (Vty.KFun n) = "F" <> (T.pack $ show n) +ppKey Vty.KBackTab = "BackTab" +ppKey Vty.KEsc = "Esc" +ppKey Vty.KBS = "Backspace" +ppKey Vty.KEnter = "Enter" +ppKey Vty.KUp = "Up" +ppKey Vty.KDown = "Down" +ppKey Vty.KLeft = "Left" +ppKey Vty.KRight = "Right" +ppKey Vty.KHome = "Home" +ppKey Vty.KEnd = "End" +ppKey Vty.KPageUp = "PgUp" +ppKey Vty.KPageDown = "PgDown" +ppKey Vty.KDel = "Del" +ppKey Vty.KUpLeft = "UpLeft" +ppKey Vty.KUpRight = "UpRight" +ppKey Vty.KDownLeft = "DownLeft" +ppKey Vty.KDownRight = "DownRight" +ppKey Vty.KCenter = "Center" +ppKey Vty.KPrtScr = "PrintScreen" +ppKey Vty.KPause = "Pause" +ppKey Vty.KIns = "Insert" +ppKey Vty.KBegin = "Begin" +ppKey Vty.KMenu = "Menu" + +nonCharKeys :: [T.Text] +nonCharKeys = map ppKey + [ Vty.KBackTab, Vty.KEsc, Vty.KBS, Vty.KEnter, Vty.KUp, Vty.KDown + , Vty.KLeft, Vty.KRight, Vty.KHome, Vty.KEnd, Vty.KPageDown + , Vty.KPageUp, Vty.KDel, Vty.KUpLeft, Vty.KUpRight, Vty.KDownLeft + , Vty.KDownRight, Vty.KCenter, Vty.KPrtScr, Vty.KPause, Vty.KIns + , Vty.KBegin, Vty.KMenu + ] + +ppChar :: Char -> T.Text +ppChar '\t' = "Tab" +ppChar ' ' = "Space" +ppChar c = T.singleton c + +ppMod :: Vty.Modifier -> T.Text +ppMod Vty.MMeta = "M" +ppMod Vty.MAlt = "A" +ppMod Vty.MCtrl = "C" +ppMod Vty.MShift = "S" + +parseBindingList :: T.Text -> Either String BindingState +parseBindingList t = + if T.toLower t == "unbound" + then return Unbound + else BindingList <$> mapM (parseBinding . T.strip) (T.splitOn "," t) + +keyEventFromName :: T.Text -> Either String KeyEvent +keyEventFromName t = + let mapping = M.fromList [ (keyEventName e, e) | e <- allEvents ] + in case M.lookup t mapping of + Just e -> return e + Nothing -> Left ("Unknown event: " ++ show t) + +keyEventName :: KeyEvent -> T.Text +keyEventName ev = case ev of + QuitEvent -> "quit" + VtyRefreshEvent -> "vty-refresh" + ClearUnreadEvent -> "clear-unread" + CancelEvent -> "cancel" + + ToggleMessagePreviewEvent -> "toggle-message-preview" + InvokeEditorEvent -> "invoke-editor" + ToggleMultiLineEvent -> "toggle-multiline" + ReplyRecentEvent -> "reply-recent" + + EnterFastSelectModeEvent -> "enter-fast-select" + NextChannelEvent -> "focus-next-channel" + PrevChannelEvent -> "focus-prev-channel" + NextUnreadChannelEvent -> "focus-next-unread" + LastChannelEvent -> "focus-last-channel" + + EnterFlaggedPostsEvent -> "show-flagged-posts" + ShowHelpEvent -> "show-help" + EnterSelectModeEvent -> "select-mode" + EnterOpenURLModeEvent -> "enter-url-open" + + LoadMoreEvent -> "load-more" + OpenMessageURLEvent -> "open-message-url" + + ScrollUpEvent -> "scroll-up" + ScrollDownEvent -> "scroll-down" + PageUpEvent -> "page-up" + PageDownEvent -> "page-down" + ScrollTopEvent -> "scroll-top" + ScrollBottomEvent -> "scroll-bottom" + + SelectUpEvent -> "select-up" + SelectDownEvent -> "select-down" + + FlagMessageEvent -> "flag-message" + YankMessageEvent -> "yank-message" + DeleteMessageEvent -> "delete-message" + EditMessageEvent -> "edit-message" + ReplyMessageEvent -> "reply-message" diff --git a/src/Types/Messages.hs b/src/Types/Messages.hs --- a/src/Types/Messages.hs +++ b/src/Types/Messages.hs @@ -1,12 +1,43 @@ -{-# LANGUAGE DeriveFunctor #-} -{-# LANGUAGE DeriveFoldable #-} -{-# LANGUAGE DeriveTraversable #-} {-# LANGUAGE MultiParamTypeClasses #-} {-# LANGUAGE FlexibleInstances #-} {-# LANGUAGE TemplateHaskell #-} +{-| + +The 'Message' is a single displayed event in a Channel. All Messages +have a date/time, and messages that represent posts to the channel +have a (hash) ID, and displayable text, along with other attributes. + +All Messages are sorted chronologically. There is no assumption that +the server date/time is synchronized with the local date/time, so all +of the Message ordering uses the server's date/time. + +The mattermost-api retrieves a 'Post' from the server, briefly encodes +the useful portions of that as a 'ClientPost' object and then converts +it to a 'Message' inserting this result it into the collection of +Messages associated with a Channel. The PostID of the message +uniquely identifies that message and can be used to interact with the +server for subsequent operations relative to that message's 'Post'. +The date/time associated with these messages is generated by the +server. + +There are also "messages" generated directly by the Matterhorn client +which can be used to display additional, client-related information to +the user. Examples of these client messages are: date boundaries, the +"new messages" marker, errors from invoking the browser, etc. These +client-generated messages will have a date/time although it is locally +generated (usually by relation to an associated Post). + +Most other Matterhorn operations primarily are concerned with +user-posted messages (@case mPostId of Just _@ or @case mType of CP +_@), but others will include client-generated messages (@case mPostId +of Nothing@ or @case mType of C _@). + +--} + module Types.Messages - ( Message(..) + ( -- * Message and operations on a single Message + Message(..) , isDeletable, isReplyable, isEditable, isReplyTo , mText, mUserName, mDate, mType, mPending, mDeleted , mAttachments, mInReplyToMsg, mPostId, mReactions, mFlagged @@ -15,21 +46,24 @@ , ReplyState(..) , clientMessageToMessage , newMessageOfType + -- * Message Collections , Messages , ChronologicalMessages , RetrogradeMessages , MessageOps (..) , noMessages + , filterMessages + , reverseMessages + , unreverseMessages + -- * Operations on Posted Messages , splitMessages , findMessage - , filterMessages , getNextPostId , getPrevPostId , getLatestPostId , findLatestUserMessage + -- * Operations on any Message type , messagesAfter - , reverseMessages - , unreverseMessages ) where @@ -39,11 +73,12 @@ import Data.Maybe (isJust) import qualified Data.Sequence as Seq import qualified Data.Text as T -import Data.Time.Clock (UTCTime) import Lens.Micro.Platform -import Network.Mattermost.Types (ChannelId, PostId, Post) +import Network.Mattermost.Types (ChannelId, PostId, Post, ServerTime) +import Types.DirectionalSeq import Types.Posts +-- ---------------------------------------------------------------------- -- * Messages -- | A 'Message' is any message we might want to render, either from @@ -51,7 +86,7 @@ data Message = Message { _mText :: Blocks , _mUserName :: Maybe T.Text - , _mDate :: UTCTime + , _mDate :: ServerTime , _mType :: MessageType , _mPending :: Bool , _mDeleted :: Bool @@ -94,7 +129,10 @@ | InReplyTo PostId deriving (Show) --- | Convert a 'ClientMessage' to a 'Message' +-- | Convert a 'ClientMessage' to a 'Message'. A 'ClientMessage' is +-- one that was generated by the Matterhorn client and which the +-- server knows nothing about. For example, an error message +-- associated with passing a link to the local browser. clientMessageToMessage :: ClientMessage -> Message clientMessageToMessage cm = Message { _mText = getBlocks (cm^.cmText) @@ -112,7 +150,7 @@ , _mChannelId = Nothing } -newMessageOfType :: T.Text -> MessageType -> UTCTime -> Message +newMessageOfType :: T.Text -> MessageType -> ServerTime -> Message newMessageOfType text typ d = Message { _mText = getBlocks text , _mUserName = Nothing @@ -135,32 +173,6 @@ -- ---------------------------------------------------------------------- --- These declarations allow the use of a DirectionalSeq, which is a Seq --- that uses a phantom type to identify the ordering of the elements --- in the sequence (Forward or Reverse). The constructors are not --- exported from this module so that a DirectionalSeq can only be --- constructed by the functions in this module. - -data Chronological -data Retrograde -class SeqDirection a -instance SeqDirection Chronological -instance SeqDirection Retrograde - -data SeqDirection dir => DirectionalSeq dir a = - DSeq { dseq :: Seq.Seq a } - deriving (Show, Functor, Foldable, Traversable) - -instance SeqDirection a => Monoid (DirectionalSeq a Message) where - mempty = DSeq mempty - mappend a b = DSeq $ mappend (dseq a) (dseq b) - -onDirectedSeq :: SeqDirection dir => (Seq.Seq a -> Seq.Seq b) - -> DirectionalSeq dir a -> DirectionalSeq dir b -onDirectedSeq f = DSeq . f . dseq - --- ---------------------------------------------------------------------- - -- * Message Collections -- | A wrapper for an ordered, unique list of 'Message' values. @@ -185,8 +197,13 @@ filterMessages p = onDirectedSeq (Seq.filter p) class MessageOps a where + -- | addMessage inserts a date in proper chronological order, with + -- the following extra functionality: + -- * no duplication (by PostId) + -- * no duplication (adjacent UnknownGap entries) addMessage :: Message -> a -> a + instance MessageOps ChronologicalMessages where addMessage m ml = case Seq.viewr (dseq ml) of @@ -199,6 +216,7 @@ else dirDateInsert m ml LT -> dirDateInsert m ml + dirDateInsert :: Message -> ChronologicalMessages -> ChronologicalMessages dirDateInsert m = onDirectedSeq $ finalize . foldr insAfter initial where initial = (Just m, mempty) @@ -216,6 +234,17 @@ noMessages :: Messages noMessages = DSeq mempty +-- | Reverse the order of the messages +reverseMessages :: Messages -> RetrogradeMessages +reverseMessages = DSeq . Seq.reverse . dseq + +-- | Unreverse the order of the messages +unreverseMessages :: RetrogradeMessages -> Messages +unreverseMessages = DSeq . Seq.reverse . dseq + +-- ---------------------------------------------------------------------- +-- * Operations on Posted Messages + -- | Searches for the specified PostId and returns a tuple where the -- first element is the Message associated with the PostId (if it -- exists), and the second element is another tuple: the first element @@ -287,6 +316,7 @@ >>= _mPostId <$> Seq.index (dseq msgs) where valid m = not (m^.mDeleted) && isJust (m^.mPostId) + -- | Find the most recent message that is a message posted by a user -- that matches the test (if any), skipping local client messages and -- any user event that is not a message (i.e. find a normal message or @@ -304,14 +334,9 @@ Nothing -> Nothing Just p' -> findUserMessageFrom p' msgs +-- ---------------------------------------------------------------------- +-- * Operations on any Message type + -- | Return all messages that were posted after the specified date/time. -messagesAfter :: UTCTime -> Messages -> Messages +messagesAfter :: ServerTime -> Messages -> Messages messagesAfter viewTime = onDirectedSeq $ Seq.takeWhileR (\m -> m^.mDate > viewTime) - --- | Reverse the order of the messages -reverseMessages :: Messages -> RetrogradeMessages -reverseMessages = DSeq . Seq.reverse . dseq - --- | Unreverse the order of the messages -unreverseMessages :: RetrogradeMessages -> Messages -unreverseMessages = DSeq . Seq.reverse . dseq diff --git a/src/Types/Posts.hs b/src/Types/Posts.hs --- a/src/Types/Posts.hs +++ b/src/Types/Posts.hs @@ -51,9 +51,9 @@ import Data.Monoid ((<>)) import qualified Data.Sequence as Seq import qualified Data.Text as T -import Data.Time.Clock (UTCTime, getCurrentTime) +import Data.Time.Clock (getCurrentTime) import Lens.Micro.Platform ((^.), makeLenses) -import Network.Mattermost +import Network.Mattermost.Types import Network.Mattermost.Lenses -- * Client Messages @@ -62,15 +62,22 @@ -- like help text or an error message. data ClientMessage = ClientMessage { _cmText :: T.Text - , _cmDate :: UTCTime + , _cmDate :: ServerTime , _cmType :: ClientMessageType } deriving (Eq, Show) --- | Create a new 'ClientMessage' value +-- | Create a new 'ClientMessage' value. This is a message generated +-- by this Matterhorn client and not by (or visible to) the Server. +-- These should be visible, but not necessarily integrated into any +-- special position in the output stream (i.e., they should generally +-- appear at the bottom of the messages display, but subsequent +-- messages should follow them), so this is a special place where +-- there is an assumed approximation of equality between local time +-- and server time. newClientMessage :: (MonadIO m) => ClientMessageType -> T.Text -> m ClientMessage newClientMessage ty msg = do now <- liftIO getCurrentTime - return (ClientMessage msg now ty) + return (ClientMessage msg (ServerTime now) ty) -- | We format 'ClientMessage' values differently depending on -- their 'ClientMessageType' @@ -94,7 +101,7 @@ { _cpText :: Blocks , _cpUser :: Maybe UserId , _cpUserOverride :: Maybe T.Text - , _cpDate :: UTCTime + , _cpDate :: ServerTime , _cpType :: ClientPostType , _cpPending :: Bool , _cpDeleted :: Bool diff --git a/src/Types/Users.hs b/src/Types/Users.hs --- a/src/Types/Users.hs +++ b/src/Types/Users.hs @@ -22,14 +22,20 @@ , getDMChannelName , userIdForDMChannel , userDeleted + , TypingUsers + , noTypingUsers + , addTypingUser + , allTypingUsers + , expireTypingUsers ) where +import Data.Semigroup ((<>), Max(..)) import qualified Data.HashMap.Strict as HM import Data.List (sort) import Data.Maybe (listToMaybe, maybeToList) -import Data.Monoid ((<>)) import qualified Data.Text as T +import Data.Time (UTCTime) import Lens.Micro.Platform import Network.Mattermost.Types (Id(Id), UserId(..), User(..), idString) @@ -75,6 +81,7 @@ = Online | Away | Offline + | DoNotDisturb | Other T.Text deriving (Eq, Show) @@ -83,6 +90,7 @@ "online" -> Online "offline" -> Offline "away" -> Away + "dnd" -> DoNotDisturb _ -> Other t -- ** 'UserInfo' lenses @@ -95,12 +103,12 @@ newtype AllMyUsers a = AllUsers { _ofUsers :: HM.HashMap UserId a } deriving Functor +makeLenses ''AllMyUsers + -- | Define the exported typename which universally binds the -- collection to the UserInfo type. type Users = AllMyUsers UserInfo -makeLenses ''AllMyUsers - -- | Initial collection of Users with no members noUsers :: Users noUsers = AllUsers HM.empty @@ -112,6 +120,29 @@ -- | Get a list of all known users allUsers :: Users -> [UserInfo] allUsers = HM.elems . _ofUsers + +-- | Define the exported typename to represent the collection of users +-- | who are currently typing. The values kept against the user id keys are the +-- | latest timestamps of typing events from the server. +type TypingUsers = AllMyUsers (Max UTCTime) + +-- | Initial collection of TypingUsers with no members +noTypingUsers :: TypingUsers +noTypingUsers = AllUsers HM.empty + +-- | Add a member to the existing collection of TypingUsers +addTypingUser :: UserId -> UTCTime -> TypingUsers -> TypingUsers +addTypingUser uId ts = AllUsers . HM.insertWith (<>) uId (Max ts) . _ofUsers + +-- | Get a list of all typing users +allTypingUsers :: TypingUsers -> [UserId] +allTypingUsers = HM.keys . _ofUsers + +-- | Remove all the expired users from the collection of TypingUsers. +-- | Expiry is decided by the given timestamp. +expireTypingUsers :: UTCTime -> TypingUsers -> TypingUsers +expireTypingUsers expiryTimestamp = + AllUsers . HM.filter (\(Max ts') -> ts' >= expiryTimestamp) . _ofUsers -- | Get the User information given the UserId findUserById :: UserId -> Users -> Maybe UserInfo diff --git a/test/test_messages.hs b/test/test_messages.hs --- a/test/test_messages.hs +++ b/test/test_messages.hs @@ -10,7 +10,6 @@ import Data.Maybe (isNothing, fromJust) import Data.Monoid ((<>)) import qualified Data.Sequence as Seq -import qualified Data.Text as T import Data.Time.Calendar (Day(..)) import Data.Time.Clock (UTCTime(..), getCurrentTime , secondsToDiffTime) @@ -44,24 +43,28 @@ test_m1 :: IO Message -test_m1 = do t1 <- getCurrentTime - return $ Message Seq.empty Nothing t1 (CP NormalPost) False False Seq.empty NotAReply Nothing Map.empty Nothing False Nothing +test_m1 = do t1 <- ServerTime <$> getCurrentTime + return $ makeMsg t1 Nothing test_m2 :: IO Message -test_m2 = do t2 <- getCurrentTime - return $ Message Seq.empty Nothing t2 (CP Emote) False False Seq.empty NotAReply (Just $ fromId $ Id $ T.pack "m2") Map.empty Nothing False Nothing +test_m2 = do t2 <- ServerTime <$> getCurrentTime + return $ (makeMsg t2 (Just $ fromId $ Id "m2")) { _mType = CP Emote } test_m3 :: IO Message -test_m3 = do t3 <- getCurrentTime - return $ Message Seq.empty Nothing t3 (CP NormalPost) False False Seq.empty NotAReply (Just $ fromId $ Id $ T.pack "m3") Map.empty Nothing False Nothing +test_m3 = do t3 <- ServerTime <$> getCurrentTime + return $ makeMsg t3 (Just $ fromId $ Id "m3") setDateOrderMessages :: [Message] -> [Message] setDateOrderMessages = snd . foldl setTimeAndInsert (startTime, []) where setTimeAndInsert (t, ml) m = let t2 = tick t in (t2, ml ++ [m {_mDate = t2}]) - startTime = UTCTime (ModifiedJulianDay 100) (secondsToDiffTime 0) - tick (UTCTime d t) = UTCTime d $ succ t + startTime = ServerTime $ UTCTime (ModifiedJulianDay 100) (secondsToDiffTime 0) + tick (ServerTime (UTCTime d t)) = ServerTime $ UTCTime d $ succ t +makeMsg :: ServerTime -> Maybe PostId -> Message +makeMsg t pId = Message Seq.empty Nothing t (CP NormalPost) False False Seq.empty NotAReply + pId Map.empty Nothing False Nothing + makeMsgs :: [Message] -> Messages makeMsgs = foldr addMessage noMessages @@ -213,7 +216,7 @@ , testProperty "duplicate dates different IDs in posted order" $ \(w, x, y, z) -> - let d = UTCTime + let d = ServerTime $ UTCTime (ModifiedJulianDay 1234) (secondsToDiffTime 9876) l = foldl (setTime d) [] $ postMsg <$> [w, x, y, z]