matterhorn 40400.0.0 → 40600.0.0
raw patch · 48 files changed
+2387/−1097 lines, 48 filesdep +aesondep +asyncdep +semigroupsdep ~brickdep ~mattermost-apidep ~mattermost-api-qc
Dependencies added: aeson, async, semigroups, timezone-olson, timezone-series, word-wrap
Dependency ranges changed: brick, mattermost-api, mattermost-api-qc, vty
Files
- CHANGELOG.md +47/−1
- README.md +13/−6
- matterhorn.cabal +22/−8
- src/App.hs +3/−12
- src/Command.hs +13/−4
- src/Config.hs +37/−21
- src/Connection.hs +50/−15
- src/Constants.hs +7/−0
- src/Draw/ChannelList.hs +99/−42
- src/Draw/JoinChannel.hs +10/−4
- src/Draw/Main.hs +132/−88
- src/Draw/Messages.hs +18/−7
- src/Draw/PostListOverlay.hs +5/−31
- src/Draw/ShowHelp.hs +149/−55
- src/Draw/Util.hs +33/−15
- src/Events.hs +119/−5
- src/Events/ChannelScroll.hs +21/−24
- src/Events/ChannelSelect.hs +16/−27
- src/Events/Keybindings.hs +123/−0
- src/Events/Main.hs +57/−58
- src/Events/MessageSelect.hs +24/−47
- src/Events/PostListOverlay.hs +9/−26
- src/Events/ShowHelp.hs +37/−25
- src/Events/UrlSelect.hs +14/−16
- src/FilePaths.hs +11/−0
- src/HelpTopics.hs +6/−0
- src/InputHistory.hs +1/−1
- src/LastRunState.hs +97/−0
- src/Login.hs +57/−98
- src/Main.hs +15/−0
- src/Markdown.hs +104/−81
- src/State.hs +159/−106
- src/State/Common.hs +7/−13
- src/State/Editing.hs +54/−19
- src/State/PostListOverlay.hs +5/−7
- src/State/Setup.hs +92/−46
- src/State/Setup/Threads.hs +43/−13
- src/TeamSelect.hs +1/−1
- src/Themes.hs +4/−14
- src/TimeUtils.hs +72/−0
- src/Types.hs +101/−70
- src/Types/Channels.hs +39/−25
- src/Types/DirectionalSeq.hs +36/−0
- src/Types/KeyEvents.hs +293/−0
- src/Types/Messages.hs +72/−47
- src/Types/Posts.hs +13/−6
- src/Types/Users.hs +34/−3
- test/test_messages.hs +13/−10
CHANGELOG.md view
@@ -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.
README.md view
@@ -1,4 +1,4 @@-[](https://hackage.haskell.org/package/matterhorn) [](https://travis-ci.org/matterhorn-chat/matterhorn) @@ -7,6 +7,12 @@  +# 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
matterhorn.cabal view
@@ -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
src/App.hs view
@@ -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 ()
src/Command.hs view
@@ -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 ->
src/Config.hs view
@@ -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)
src/Connection.hs view
@@ -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 ()
src/Constants.hs view
@@ -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
src/Draw/ChannelList.hs view
@@ -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
src/Draw/JoinChannel.hs view
@@ -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 ' ')
src/Draw/Main.hs view
@@ -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))
src/Draw/Messages.hs view
@@ -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
src/Draw/PostListOverlay.hs view
@@ -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
src/Draw/ShowHelp.hs view
@@ -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 <topic>`:") <=> (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) " "
src/Draw/Util.hs view
@@ -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)
src/Events.hs view
@@ -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)+ ]
src/Events/ChannelScroll.hs view
@@ -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 ()
src/Events/ChannelSelect.hs view
@@ -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 ]
+ src/Events/Keybindings.hs view
@@ -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' ]
src/Events/Main.hs view
@@ -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
src/Events/MessageSelect.hs view
@@ -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 ]
src/Events/PostListOverlay.hs view
@@ -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 ]
src/Events/ShowHelp.hs view
@@ -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+-- ]
src/Events/UrlSelect.hs view
@@ -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 ]
src/FilePaths.hs view
@@ -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.
src/HelpTopics.hs view
@@ -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 =
src/InputHistory.hs view
@@ -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)
+ src/LastRunState.hs view
@@ -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
src/Login.hs view
@@ -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'
src/Main.hs view
@@ -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 ()
src/Markdown.hs view
@@ -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
src/State.hs view
@@ -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)
src/State/Common.hs view
@@ -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)
src/State/Editing.hs view
@@ -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.
src/State/PostListOverlay.hs view
@@ -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
src/State/Setup.hs view
@@ -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
src/State/Setup/Threads.hs view
@@ -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
src/TeamSelect.hs view
@@ -14,7 +14,7 @@ import Graphics.Vty import System.Exit (exitSuccess) -import Network.Mattermost+import Network.Mattermost.Types import Markdown
src/Themes.hs view
@@ -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 =
+ src/TimeUtils.hs view
@@ -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
src/Types.hs view
@@ -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)+ }
src/Types/Channels.hs view
@@ -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
+ src/Types/DirectionalSeq.hs view
@@ -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+
+ src/Types/KeyEvents.hs view
@@ -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"
src/Types/Messages.hs view
@@ -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
src/Types/Posts.hs view
@@ -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
src/Types/Users.hs view
@@ -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
test/test_messages.hs view
@@ -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]