matterhorn 40900.0.1 → 40901.0.0
raw patch · 58 files changed
+3732/−2614 lines, 58 filesdep +randomdep +uuid
Dependencies added: random, uuid
Files
- CHANGELOG.md +38/−0
- PRACTICES.md +3/−0
- matterhorn.cabal +21/−2
- src/App.hs +3/−10
- src/Clipboard.hs +31/−0
- src/Command.hs +47/−3
- src/Config.hs +3/−0
- src/Constants.hs +9/−0
- src/Draw.hs +2/−0
- src/Draw/ChannelList.hs +1/−1
- src/Draw/Main.hs +21/−15
- src/Draw/Messages.hs +7/−1
- src/Draw/PostListOverlay.hs +1/−1
- src/Draw/ShowHelp.hs +2/−0
- src/Draw/ViewMessage.hs +53/−0
- src/Events.hs +36/−1
- src/Events/ChannelScroll.hs +2/−1
- src/Events/ChannelSelect.hs +2/−1
- src/Events/DeleteChannelConfirm.hs +1/−1
- src/Events/JoinChannel.hs +1/−1
- src/Events/Keybindings.hs +2/−0
- src/Events/LeaveChannelConfirm.hs +1/−1
- src/Events/Main.hs +6/−1
- src/Events/MessageSelect.hs +9/−3
- src/Events/ShowHelp.hs +4/−0
- src/Events/UrlSelect.hs +1/−1
- src/Events/ViewMessage.hs +54/−0
- src/Markdown.hs +6/−40
- src/Prelude/MH.hs +43/−43
- src/Scripts.hs +1/−1
- src/State.hs +0/−2054
- src/State/Async.hs +162/−0
- src/State/ChannelScroll.hs +54/−0
- src/State/ChannelSelect.hs +175/−0
- src/State/Channels.hs +873/−0
- src/State/Common.hs +187/−214
- src/State/Editing.hs +10/−2
- src/State/Flagging.hs +65/−0
- src/State/Help.hs +17/−0
- src/State/Logging.hs +33/−0
- src/State/MessageSelect.hs +245/−0
- src/State/Messages.hs +510/−56
- src/State/PostListOverlay.hs +11/−3
- src/State/Reactions.hs +41/−0
- src/State/Setup.hs +28/−11
- src/State/Setup/Threads.hs +18/−5
- src/State/Setup/Threads/Logging.hs +256/−0
- src/State/Themes.hs +33/−0
- src/State/UrlSelect.hs +48/−0
- src/State/UserListOverlay.hs +1/−1
- src/State/Users.hs +47/−0
- src/Types.hs +174/−24
- src/Types/KeyEvents.hs +6/−0
- src/Types/Messages.hs +202/−39
- src/Types/Posts.hs +19/−16
- src/Util.hs +25/−0
- test/Message_QCA.hs +19/−5
- test/test_messages.hs +62/−56
CHANGELOG.md view
@@ -1,4 +1,42 @@ +40901.0.0+=========++New features:+ * Improved logging infrastructure. Matterhorn now keeps a running+ bounded internal buffer of log messages that can be written to disk+ at any time, in addition to supporting the usual mode where all+ messages are logged to a file. This feature includes:+ * Four new commands:+ * `/log-status`: check on whether Matterhorn is currently logging+ at all.+ * `/log-start <path>`: start logging to the specified file.+ * `/log-stop`: stop any active logging.+ * `/log-snapshot <path>`: dump the internal log message buffer to+ the specified file.+ * A new optional configuration setting, `logMaxBufferSize`, which is+ the number of entries in the internal log buffer.+ * Added a new message selection mode keybinding to view individual+ messages (default: `v`, keybinding name: `view-message`). This+ keybinding causes the selected message to be displayed alone in a+ pop-up window in which horizontal and vertical scrolling can be used+ to view the entire message. This is especially useful in cases where+ a message contains a code block with lines that could not be wrapped.+ (#377)+ * Message selection mode now supports selection of error and info+ messages in addition to just user posts.+ * Message selection mode now supports yanking the contents of all+ messages, not just messages with verbatim content as before. The+ keybinding name for this is `yank-whole-message` and defaults to `Y`.+ When this binding is used, the entire message's Markdown source is+ copied to the system clipboard. (#171)++Other changes:+ * The help screen now supports the `scroll-top` and `scroll-bottom`+ events (defaulting to the `Home` and `End` keys, respectively).+ * Exceptions related to spurious network problems with `getAddrInfo` no+ longer cause client error reports (#391).+ 40900.0.1 =========
PRACTICES.md view
@@ -52,6 +52,9 @@ * Top-level functions have haddock documentation to help describe what the function is used for (and sometimes ways in which it shouldn't be used).++ * Modules with more than a few exports should have an explicit export+ list to help us identify dead code. Branching
matterhorn.cabal view
@@ -1,5 +1,5 @@ name: matterhorn-version: 40900.0.1+version: 40901.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@@ -38,15 +38,28 @@ Connection Completion App+ Clipboard Constants- State+ State.Async+ State.Channels+ State.ChannelScroll+ State.ChannelSelect State.Common State.Editing+ State.Flagging+ State.Help+ State.Logging State.Messages+ State.MessageSelect State.PostListOverlay+ State.Reactions State.Setup State.Setup.Threads+ State.Setup.Threads.Logging+ State.Themes+ State.UrlSelect State.UserListOverlay+ State.Users Zipper Themes Draw@@ -60,6 +73,7 @@ Draw.UserListOverlay Draw.JoinChannel Draw.Util+ Draw.ViewMessage InputHistory IOUtil Events@@ -75,6 +89,7 @@ Events.UserListOverlay Events.LeaveChannelConfirm Events.DeleteChannelConfirm+ Events.ViewMessage HelpTopics LastRunState Scripts@@ -93,6 +108,7 @@ Login Markdown Options+ Util Paths_matterhorn default-extensions: OverloadedStrings, ScopedTypeVariables,@@ -138,6 +154,8 @@ , timezone-series >= 0.1.6.1 && < 0.2 , aeson >= 1.2.3.0 && < 1.3 , async >= 2.2 && < 2.3+ , uuid >= 1.3 && < 1.4+ , random >= 1.1 && < 1.2 default-language: Haskell2010 test-suite test_messages@@ -193,3 +211,4 @@ , vty >= 5.20 && < 5.21 , xdg-basedir >= 0.2 && < 0.3 , semigroups >= 0.18 && < 0.19+ , uuid >= 1.3 && < 1.4
src/App.hs view
@@ -10,7 +10,6 @@ import Brick import Control.Monad.Trans.Except ( runExceptT ) import qualified Graphics.Vty as Vty-import System.IO ( IOMode(WriteMode), openFile, hClose ) import Text.Aspell ( stopAspell ) import Network.Mattermost@@ -23,6 +22,7 @@ import LastRunState import Options import State.Setup+import State.Setup.Threads.Logging ( shutdownLogManager ) import Types @@ -37,11 +37,7 @@ runMatterhorn :: Options -> Config -> IO ChatState runMatterhorn opts config = do- logFile <- case optLogLocation opts of- Just path -> Just `fmap` openFile path WriteMode- Nothing -> return Nothing-- st <- setupState logFile config+ st <- setupState (optLogLocation opts) config let mkVty = do vty <- Vty.mkVty Vty.defaultConfig@@ -56,10 +52,6 @@ Nothing -> return () Just (s, _) -> stopAspell s - case logFile of- Nothing -> return ()- Just h -> hClose h- return finalSt -- | Cleanup resources and save data for restoring on program restart.@@ -68,6 +60,7 @@ logIfError (mmCloseSession $ getResourceSession $ finalSt^.csResources) "Error in closing session" logIfError (writeHistory (finalSt^.csEditState.cedInputHistory)) "Error in writing history" logIfError (writeLastRunState finalSt) "Error in writing last run state"+ shutdownLogManager $ finalSt^.csResources.crLogManager where logIfError action msg = do done <- runExceptT $ convertIOException $ action
+ src/Clipboard.hs view
@@ -0,0 +1,31 @@+module Clipboard+ ( copyToClipboard+ )+where++import Prelude ()+import Prelude.MH++import Control.Exception ( try )+import qualified Data.Text as T+import System.Hclip ( setClipboard, ClipboardException(..) )++import Types+++copyToClipboard :: Text -> MH ()+copyToClipboard txt = do+ result <- liftIO (try (setClipboard (T.unpack txt)))+ case result of+ Left e -> do+ let errMsg = case e of+ UnsupportedOS _ ->+ "Matterhorn does not support yanking on this operating system."+ NoTextualData ->+ "Textual data is required to set the clipboard."+ MissingCommands cmds ->+ "Could not set clipboard due to missing one of the " <>+ "required program(s): " <> (T.pack $ show cmds)+ mhError $ ClipboardError errMsg+ Right () ->+ return ()
src/Command.hs view
@@ -1,6 +1,11 @@ {-# LANGUAGE GADTs #-} {-# LANGUAGE OverloadedStrings #-}-module Command where+module Command+ ( commandList+ , dispatchCommand+ , printArgSpec+ )+where import Prelude () import Prelude.MH@@ -15,10 +20,13 @@ import HelpTopics import Scripts-import State-import State.Common+import State.Help+import State.Channels+import State.ChannelSelect import State.Editing ( toggleMessagePreview )+import State.Logging import State.PostListOverlay+import State.Themes import State.UserListOverlay import Types @@ -59,54 +67,90 @@ commandList :: [Cmd] commandList = [ Cmd "quit" "Exit Matterhorn" NoArg $ \ () -> requestQuit+ , Cmd "right" "Focus on the next channel" NoArg $ \ () -> nextChannel+ , Cmd "left" "Focus on the previous channel" NoArg $ \ () -> prevChannel+ , Cmd "create-channel" "Create a new channel" (LineArg "channel name") $ \ name -> createOrdinaryChannel name+ , Cmd "delete-channel" "Delete the current channel" NoArg $ \ () -> beginCurrentChannelDeleteConfirm+ , Cmd "members" "Show the current channel's members" NoArg $ \ () -> enterChannelMembersUserList+ , Cmd "leave" "Leave the current channel" NoArg $ \ () -> startLeaveCurrentChannel+ , Cmd "join" "Browse the list of available channels" NoArg $ \ () -> startJoinChannel+ , Cmd "join" "Join the specified channel" (TokenArg "channel" NoArg) $ \(n, ()) -> joinChannelByName n+ , Cmd "theme" "List the available themes" NoArg $ \ () -> listThemes+ , Cmd "theme" "Set the color theme" (TokenArg "theme" NoArg) $ \ (themeName, ()) -> setTheme themeName+ , Cmd "topic" "Set the current channel's topic" (LineArg "topic") $ \ p -> if not (T.null p) then setChannelTopic p else return ()+ , Cmd "add-user" "Search for a user to add to the current channel" NoArg $ \ () -> enterChannelInviteUserList+ , Cmd "msg" "Chat with a user privately" NoArg $ \ () -> enterDMSearchUserList++ , Cmd "log-start" "Begin logging to the specified path"+ (TokenArg "path" NoArg) $ \ (path, ()) ->+ startLogging $ T.unpack path++ , Cmd "log-snapshot" "Dump the current log buffer to the specified path"+ (TokenArg "path" NoArg) $ \ (path, ()) ->+ logSnapshot $ T.unpack path++ , Cmd "log-stop" "Stop logging"+ NoArg $ \ () ->+ stopLogging++ , Cmd "log-status" "Show current logging status"+ NoArg $ \ () ->+ getLogDestination+ , Cmd "add-user" "Add a user to the current channel" (TokenArg "username" NoArg) $ \ (uname, ()) -> addUserToCurrentChannel uname+ , 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 channel or user" (TokenArg "channel" NoArg) $ \ (name, ()) -> changeChannel name+ , Cmd "focus" "Select from available channels" NoArg $ \ () -> beginChannelSelect+ , Cmd "help" "Show this help screen" NoArg $ \ _ -> showHelpScreen mainHelpTopic+ , Cmd "help" "Show help about a particular topic" (TokenArg "topic" NoArg) $ \ (topicName, ()) -> case lookupHelpTopic topicName of
src/Config.hs view
@@ -70,6 +70,8 @@ configPort <- fieldDefOf "port" number (configPort defaultConfig) configChannelListWidth <- fieldDefOf "channelListWidth" number (configChannelListWidth defaultConfig)+ configLogMaxBufferSize <- fieldDefOf "logMaxBufferSize" number+ (configLogMaxBufferSize defaultConfig) configTimeFormat <- fieldMbOf "timeFormat" stringField configDateFormat <- fieldMbOf "dateFormat" stringField configTheme <- fieldMbOf "theme" stringField@@ -167,6 +169,7 @@ , configAspellDictionary = Nothing , configUnsafeUseHTTP = False , configChannelListWidth = 20+ , configLogMaxBufferSize = 200 , configShowOlderEdits = True , configUserKeys = mempty , configShowTypingIndicator = False
src/Constants.hs view
@@ -1,6 +1,8 @@ module Constants ( pageAmount , userTypingExpiryInterval+ , numScrollbackPosts+ , previewMaxHeight ) where @@ -15,3 +17,10 @@ -- | The expiry interval in seconds for user typing notifications. userTypingExpiryInterval :: NominalDiffTime userTypingExpiryInterval = 5++numScrollbackPosts :: Int+numScrollbackPosts = 100++-- | The maximum height of the message preview, in lines.+previewMaxHeight :: Int+previewMaxHeight = 5
src/Draw.hs view
@@ -11,6 +11,7 @@ import Draw.PostListOverlay import Draw.ShowHelp import Draw.UserListOverlay+import Draw.ViewMessage import Types @@ -29,3 +30,4 @@ DeleteChannelConfirm -> drawDeleteChannelConfirm st PostListOverlay contents -> drawPostListOverlay contents st UserListOverlay -> drawUserListOverlay st+ ViewMessage -> drawViewMessage st
src/Draw/ChannelList.hs view
@@ -30,7 +30,7 @@ import Lens.Micro.Platform (Getting, at, non) import Draw.Util-import State+import State.Channels import Themes import Types
src/Draw/Main.hs view
@@ -29,17 +29,19 @@ import Completion ( Completer(..), CompletionAlternative(..), currentAlternative )+import Constants import Draw.ChannelList ( renderChannelList ) import Draw.Messages import Draw.Util import Events.Keybindings import Events.MessageSelect import Markdown-import State+import State.MessageSelect import Themes import TimeUtils ( justAfter, justBefore ) import Types import Types.KeyEvents+import Types.Messages ( msgURLs ) previewFromInput :: Maybe MessageType -> UserId -> Text -> Maybe Message@@ -56,6 +58,7 @@ in if isCommand && not isEmote then Nothing else Just $ Message { _mText = getBlocks content+ , _mMarkdownSource = content , _mUser = UserI uId , _mDate = ServerTime $ UTCTime (fromGregorian 1970 1 1) 0 -- The date is not used for preview@@ -68,7 +71,7 @@ , _mDeleted = False , _mAttachments = mempty , _mInReplyToMsg = NotAReply- , _mPostId = Nothing+ , _mMessageId = Nothing , _mReactions = mempty , _mOriginalPost = Nothing , _mFlagged = False@@ -340,7 +343,7 @@ renderMessagesWithSelect (st^.csMessageSelect) channelMessages _ -> renderLastMessages $ reverseMessages channelMessages - renderMessagesWithSelect (MessageSelectState selPostId) msgs =+ renderMessagesWithSelect (MessageSelectState selMsgId) msgs = -- In this case, we want to fill the message list with messages -- but use the post ID as a cursor. To do this efficiently we -- only want to render enough messages to fill the screen.@@ -354,7 +357,7 @@ -- First, we sanity-check the application state because under -- some conditions, the selected message might be gone (e.g. -- deleted).- let (s, (before, after)) = splitMessages selPostId msgs+ let (s, (before, after)) = splitMessages selMsgId msgs in case s of Nothing -> renderLastMessages before Just m ->@@ -457,9 +460,21 @@ , kbEvent = b } <- keymap , e' == e ]- options = [ ( isReplyable+ options = [ ( const True+ , ev YankWholeMessageEvent+ , "yank-all" )+ , ( \m -> isFlaggable m && not (m^.mFlagged)+ , ev FlagMessageEvent+ , "flag" )+ , ( \m -> isFlaggable m && m^.mFlagged+ , ev FlagMessageEvent+ , "unflag" )+ , ( isReplyable , ev ReplyMessageEvent , "reply" )+ , ( const True+ , ev ViewMessageEvent+ , "view" ) , ( \m -> isMine st m && isEditable m , ev EditMessageEvent , "edit" )@@ -471,13 +486,7 @@ , openUrlsMsg ) , ( const hasVerb , ev YankMessageEvent- , "yank" )- , ( \m -> not (m^.mFlagged)- , ev FlagMessageEvent- , "flag" )- , ( \m -> m^.mFlagged- , ev FlagMessageEvent- , "unflag" )+ , "yank-code" ) ] Just postMsg = getSelectedMessage st @@ -504,9 +513,6 @@ , txt "]" , borderElem bsHorizontal ]--previewMaxHeight :: Int-previewMaxHeight = 5 maybePreviewViewport :: Widget Name -> Widget Name maybePreviewViewport w =
src/Draw/Messages.hs view
@@ -1,4 +1,10 @@-module Draw.Messages where+module Draw.Messages+ ( nameForUserRef+ , maxMessageHeight+ , renderSingleMessage+ , unsafeRenderMessageSelection+ )+where import Brick import Brick.Widgets.Border
src/Draw/PostListOverlay.hs view
@@ -95,7 +95,7 @@ -- The full message list, rendered with the current selection renderedMessageList =- let (s, (before, after)) = splitMessages (st^.csPostListOverlay.postListSelected) messages+ let (s, (before, after)) = splitMessages (MessagePostId <$> st^.csPostListOverlay.postListSelected) messages in case s of Nothing -> map renderMessageForOverlay (reverse (toList messages)) Just curMsg ->
src/Draw/ShowHelp.hs view
@@ -24,6 +24,7 @@ import Events.ShowHelp import Events.UrlSelect import Events.UserListOverlay+import Events.ViewMessage import HelpTopics ( helpTopics ) import Markdown ( renderText ) import Options ( mhVersion )@@ -355,6 +356,7 @@ , ("Text Editing", editingKeybindings) , ("Flagged Messages", postListOverlayKeybindings kc) , ("User Listings", userListOverlayKeybindings kc)+ , ("Message Viewer", viewMessageKeybindings kc) ] helpBox :: Name -> Widget Name -> Widget Name
+ src/Draw/ViewMessage.hs view
@@ -0,0 +1,53 @@+module Draw.ViewMessage+ ( drawViewMessage+ )+where++import Prelude ()+import Prelude.MH++import Brick+import Brick.Widgets.Border+import Brick.Widgets.Center+import Lens.Micro.Platform ( to )++import Draw.Main+import Draw.Messages ( nameForUserRef )+import Markdown+import Themes+import Types+++drawViewMessage :: ChatState -> [Widget Name]+drawViewMessage st = (viewMessageBox st) : (forceAttr "invalid" <$> drawMain st)++viewMessageBox :: ChatState -> Widget Name+viewMessageBox st =+ let body = case st^.csViewedMessage of+ Nothing -> str "BUG: no message to show, please report!"+ Just msg ->+ let hs = getHighlightSet st+ in cached ViewMessageArea $+ renderMessage $ MessageData { mdEditThreshold = Nothing+ , mdShowOlderEdits = False+ , mdMessage = msg+ , mdUserName = msg^.mUser.to (nameForUserRef st)+ , mdParentMessage = Nothing+ , mdParentUserName = Nothing+ , mdRenderReplyParent = True+ , mdHighlightSet = hs+ , mdIndentBlocks = True+ }++ in centerLayer $+ Widget Fixed Fixed $ do+ ctx <- getContext+ let maxWidth = 80+ maxHeight = 25+ width = min maxWidth (ctx^.availWidthL)+ height = min maxHeight (ctx^.availHeightL)+ render $ vLimit height $+ hLimit width $+ borderWithLabel (withDefAttr clientEmphAttr $ str "View Message") $+ viewport ViewMessageArea Both $+ body
src/Events.hs view
@@ -12,6 +12,7 @@ import qualified Graphics.Vty as Vty import Lens.Micro.Platform ( (.=) ) +import qualified Network.Mattermost.Endpoints as MM import Network.Mattermost.Exceptions ( mattermostErrorMessage ) import Network.Mattermost.Lenses import Network.Mattermost.Types@@ -19,8 +20,12 @@ import Connection import HelpTopics-import State+import State.Channels import State.Common+import State.Flagging+import State.Messages+import State.Reactions+import State.Users import Types import Types.Common import Types.KeyEvents@@ -37,6 +42,7 @@ import Events.ShowHelp import Events.UrlSelect import Events.UserListOverlay+import Events.ViewMessage onEvent :: ChatState -> BrickEvent Name MHEvent -> EventM Name (Next ChatState)@@ -73,6 +79,24 @@ handleIEvent :: InternalEvent -> MH () handleIEvent (DisplayError e) = postErrorMessage' $ formatError e+handleIEvent (LoggingStarted path) =+ postInfoMessage $ "Logging to " <> T.pack path+handleIEvent (LogDestination dest) =+ case dest of+ Nothing ->+ postInfoMessage "Logging is currently disabled. Enable it with /log-start."+ Just path ->+ postInfoMessage $ T.pack $ "Logging to " <> path+handleIEvent (LogSnapshotSucceeded path) =+ postInfoMessage $ "Log snapshot written to " <> T.pack path+handleIEvent (LoggingStopped path) =+ postInfoMessage $ "Stopped logging to " <> T.pack path+handleIEvent (LogStartFailed path err) =+ postErrorMessage' $ "Could not start logging to " <> T.pack path <>+ ", error: " <> T.pack err+handleIEvent (LogSnapshotFailed path err) =+ postErrorMessage' $ "Could not write log snapshot to " <> T.pack path <>+ ", error: " <> T.pack err formatError :: MHError -> T.Text formatError (GenericError msg) =@@ -130,6 +154,7 @@ DeleteChannelConfirm -> onEventDeleteChannelConfirm e PostListOverlay _ -> onEventPostListOverlay e UserListOverlay -> onEventUserListOverlay e+ ViewMessage -> onEventViewMessage e handleWSEvent :: WebsocketEvent -> MH () handleWSEvent we = do@@ -363,3 +388,13 @@ , ("message select", messageSelectKeybindings kc) , ("post list overlay", postListOverlayKeybindings kc) ]++-- | Refresh client-accessible server configuration information. This+-- is usually triggered when a reconnect event for the WebSocket to the+-- server occurs.+refreshClientConfig :: MH ()+refreshClientConfig = do+ session <- getSession+ doAsyncWith Preempt $ do+ cfg <- MM.mmGetClientConfiguration (Just "old") session+ return (csClientConfig .= Just cfg)
src/Events/ChannelScroll.hs view
@@ -7,7 +7,8 @@ import qualified Graphics.Vty as Vty import Events.Keybindings-import State+import State.ChannelScroll+import State.UrlSelect import Types
src/Events/ChannelSelect.hs view
@@ -8,7 +8,8 @@ import Lens.Micro.Platform ( (%=) ) import Events.Keybindings-import State+import State.Channels+import State.ChannelSelect import Types
src/Events/DeleteChannelConfirm.hs view
@@ -6,7 +6,7 @@ import qualified Graphics.Vty as Vty import Types-import State+import State.Channels onEventDeleteChannelConfirm :: Vty.Event -> MH ()
src/Events/JoinChannel.hs view
@@ -9,7 +9,7 @@ import Network.Mattermost.Types ( getId ) -import State ( joinChannel )+import State.Channels ( joinChannel ) import Types
src/Events/Keybindings.hs view
@@ -133,8 +133,10 @@ SearchSelectUpEvent -> [ ctrl (key 'p'), kb Vty.KUp ] SearchSelectDownEvent -> [ ctrl (key 'n'), kb Vty.KDown ] + ViewMessageEvent -> [ key 'v' ] FlagMessageEvent -> [ key 'f' ] YankMessageEvent -> [ key 'y' ]+ YankWholeMessageEvent -> [ key 'Y' ] DeleteMessageEvent -> [ key 'd' ] EditMessageEvent -> [ key 'e' ] ReplyMessageEvent -> [ key 'r' ]
src/Events/LeaveChannelConfirm.hs view
@@ -5,7 +5,7 @@ import qualified Graphics.Vty as Vty -import State+import State.Channels import Types
src/Events/Main.hs view
@@ -23,9 +23,14 @@ import Events.Keybindings import HelpTopics ( mainHelpTopic ) import InputHistory-import State+import State.Help+import State.Channels+import State.ChannelSelect import State.Editing+import State.MessageSelect import State.PostListOverlay ( enterFlaggedPostListMode )+import State.UrlSelect+import State.Messages ( sendMessage ) import Types
src/Events/MessageSelect.hs view
@@ -7,7 +7,7 @@ import qualified Graphics.Vty as Vty import Events.Keybindings-import State+import State.MessageSelect import Types @@ -53,10 +53,16 @@ , mkKb DeleteMessageEvent "Delete the selected message (with confirmation)" beginConfirmDeleteSelectedMessage - , mkKb YankMessageEvent "Copy a verbatim section to the clipboard"- copyVerbatimToClipboard+ , mkKb YankMessageEvent "Copy a verbatim section or message to the clipboard"+ yankSelectedMessageVerbatim + , mkKb YankWholeMessageEvent "Copy an entire message to the clipboard"+ yankSelectedMessage+ , mkKb FlagMessageEvent "Flag the selected message" flagSelectedMessage++ , mkKb ViewMessageEvent "View the selected message"+ viewSelectedMessage ]
src/Events/ShowHelp.hs view
@@ -29,6 +29,10 @@ mh $ vScrollBy (viewportScroll HelpViewport) (1 * pageAmount) , mkKb CancelEvent "Return to the main interface" $ setMode Main+ , mkKb ScrollBottomEvent "Scroll to the end of the help" $+ mh $ vScrollToEnd (viewportScroll HelpViewport)+ , mkKb ScrollTopEvent "Scroll to the beginning of the help" $+ mh $ vScrollToBeginning (viewportScroll HelpViewport) ] -- KB "Scroll up"
src/Events/UrlSelect.hs view
@@ -7,7 +7,7 @@ import qualified Graphics.Vty as Vty import Events.Keybindings-import State+import State.UrlSelect import Types
+ src/Events/ViewMessage.hs view
@@ -0,0 +1,54 @@+module Events.ViewMessage+ ( onEventViewMessage+ , viewMessageKeybindings+ )+where++import Prelude ()+import Prelude.MH++import Brick.Main+import qualified Graphics.Vty as Vty++import Constants+import Events.Keybindings+import Types+++onEventViewMessage :: Vty.Event -> MH ()+onEventViewMessage =+ handleKeyboardEvent viewMessageKeybindings handleMessageViewEvent++vs :: ViewportScroll Name+vs = viewportScroll ViewMessageArea++handleMessageViewEvent :: Vty.Event -> MH ()+handleMessageViewEvent (Vty.EvKey Vty.KLeft []) =+ mh $ hScrollBy vs (-1)+handleMessageViewEvent (Vty.EvKey Vty.KRight []) =+ mh $ hScrollBy vs 1+handleMessageViewEvent _ = return ()++viewMessageKeybindings :: KeyConfig -> [Keybinding]+viewMessageKeybindings = mkKeybindings+ [ mkKb CancelEvent "Close window" $+ setMode Main++ , mkKb PageUpEvent "Page up" $+ mh $ vScrollBy vs (-1 * pageAmount)++ , mkKb PageDownEvent "Page down" $+ mh $ vScrollBy vs pageAmount++ , mkKb ScrollUpEvent "Scroll up" $+ mh $ vScrollBy vs (-1)++ , mkKb ScrollDownEvent "Scroll down" $+ mh $ vScrollBy vs 1++ , mkKb ScrollBottomEvent "Scroll to the end of the message" $+ mh $ vScrollToEnd vs++ , mkKb ScrollTopEvent "Scroll to the beginning of the message" $+ mh $ vScrollToBeginning vs+ ]
src/Markdown.hs view
@@ -8,7 +8,6 @@ , renderMessage , renderText , renderText'- , blockGetURLs , cursorSentinel , addEllipsis , replyArrow@@ -19,7 +18,7 @@ import Prelude () import Prelude.MH -import Brick ( (<+>), Widget, textWidth )+import Brick ( (<+>), Widget(Widget), textWidth ) import qualified Brick as B import qualified Brick.Widgets.Border as B import qualified Brick.Widgets.Border.Style as B@@ -271,7 +270,7 @@ blockToWidget hSet (C.Para is) = toInlineChunk is hSet blockToWidget hSet (C.Header n is) = B.withDefAttr clientHeaderAttr $- hBox [header n, B.txt " ", toInlineChunk is hSet]+ hBox [B.padRight (B.Pad 1) $ header n, toInlineChunk is hSet] blockToWidget hSet (C.Blockquote is) = addQuoting (vBox $ fmap (blockToWidget hSet) is) blockToWidget hSet (C.List _ l bs) = blocksToList l bs hSet@@ -541,45 +540,12 @@ | T.any (== cursorSentinel) t = B.visible $ B.txt $ removeCursor t | otherwise = B.txt t -inlinesText :: Seq C.Inline -> Text-inlinesText = F.fold . fmap go- where go (C.Str t) = t- go C.Space = " "- go C.SoftBreak = " "- go C.LineBreak = " "- go (C.Emph is) = F.fold (fmap go is)- go (C.Strong is) = F.fold (fmap go is)- go (C.Code t) = t- go (C.Link is _ _) = F.fold (fmap go is)- go (C.Image is _ _) = "[image" <> altInlinesString is <> "]"- go (C.Entity t) = t- go (C.RawHtml t) = t--altInlinesString :: Seq C.Inline -> Text-altInlinesString is | S.null is = ""- | otherwise = ":" <> inlinesText is--blockGetURLs :: C.Block -> Seq (Text, Text)-blockGetURLs (C.Para is) = mconcat $ inlineGetURLs <$> toList is-blockGetURLs (C.Header _ is) = mconcat $ inlineGetURLs <$> toList is-blockGetURLs (C.Blockquote bs) = mconcat $ blockGetURLs <$> toList bs-blockGetURLs (C.List _ _ bss) = mconcat $ mconcat $ (blockGetURLs <$>) <$> (toList <$> bss)-blockGetURLs _ = mempty--inlineGetURLs :: C.Inline -> Seq (Text, Text)-inlineGetURLs (C.Emph is) = mconcat $ inlineGetURLs <$> toList is-inlineGetURLs (C.Strong is) = mconcat $ inlineGetURLs <$> toList is-inlineGetURLs (C.Link is url "") = (url, inlinesText is) S.<| (mconcat $ inlineGetURLs <$> toList is)-inlineGetURLs (C.Link is _ url) = (url, inlinesText is) S.<| (mconcat $ inlineGetURLs <$> toList is)-inlineGetURLs (C.Image is url _) = S.singleton (url, inlinesText is)-inlineGetURLs _ = mempty- replyArrow :: Widget a replyArrow =- hBox [ B.str " "- , B.borderElem B.bsCornerTL- , B.str "▸"- ]+ Widget B.Fixed B.Fixed $ do+ ctx <- B.getContext+ let bs = ctx^.B.ctxBorderStyleL+ B.render $ B.str [' ', B.bsCornerTL bs, '▸'] findVerbatimChunk :: C.Blocks -> Maybe Text findVerbatimChunk = getFirst . F.foldMap go
src/Prelude/MH.hs view
@@ -7,56 +7,56 @@ -} module Prelude.MH-( module P+ ( module P #if !MIN_VERSION_base(4,11,0)-, (<>)+ , (<>) #endif-, (<|>)--- commonly-used functions from Maybe-, Maybe.isJust-, Maybe.isNothing-, Maybe.listToMaybe-, Maybe.maybeToList-, Maybe.fromMaybe-, Maybe.catMaybes+ , (<|>)+ -- commonly-used functions from Maybe+ , Maybe.isJust+ , Maybe.isNothing+ , Maybe.listToMaybe+ , Maybe.maybeToList+ , Maybe.fromMaybe+ , Maybe.catMaybes --- a non-partial Read function-, Read.readMaybe+ -- a non-partial Read function+ , Read.readMaybe --- commonly-used functions from Monad-, Monad.forM-, Monad.forM_-, Monad.filterM-, Monad.when-, Monad.unless-, Monad.void-, Monad.join-, Monad.forever-, Monad.foldM-, Monad.MonadIO(..)+ -- commonly-used functions from Monad+ , Monad.forM+ , Monad.forM_+ , Monad.filterM+ , Monad.when+ , Monad.unless+ , Monad.void+ , Monad.join+ , Monad.forever+ , Monad.foldM+ , Monad.MonadIO(..) --- commonly-used functions from List-, Foldable.toList-, List.find-, List.sort-, List.intercalate-, Exts.sortWith-, Exts.groupWith+ -- commonly-used functions from List+ , Foldable.toList+ , List.find+ , List.sort+ , List.intercalate+ , Exts.sortWith+ , Exts.groupWith --- common read-only lens operators-, (Lens.&)-, (Lens.^.)-, Lens.use+ -- common read-only lens operators+ , (Lens.&)+ , (Lens.^.)+ , Lens.use --- various type aliases-, Text-, HashMap-, Seq-, Set-, Time.UTCTime-, Time.TimeZoneSeries-, Time.NominalDiffTime-)+ -- various type aliases+ , Text+ , HashMap+ , Seq+ , Set+ , Time.UTCTime+ , Time.TimeZoneSeries+ , Time.NominalDiffTime+ ) where
src/Scripts.hs view
@@ -13,8 +13,8 @@ import System.Exit ( ExitCode(..) ) import FilePaths ( Script(..), getAllScripts, locateScriptPath )-import State ( sendMessage, runLoggedCommand ) import State.Common+import State.Messages ( sendMessage ) import Types
− src/State.hs
@@ -1,2054 +0,0 @@-{-# LANGUAGE LambdaCase #-}-{-# LANGUAGE MultiWayIf #-}-module State- (- -- * Message flagging- updateMessageFlag- , flagMessage-- -- * Running external programs- , runLoggedCommand-- -- * Channel sidebar selection- , prevChannel- , nextChannel- , recentChannel- , nextUnreadChannel-- -- * Working with channels- , createOrdinaryChannel- , startJoinChannel- , joinChannel- , joinChannelByName- , changeChannel- , disconnectChannels- , startLeaveCurrentChannel- , leaveCurrentChannel- , leaveChannel- , removeChannelFromState- , beginCurrentChannelDeleteConfirm- , deleteCurrentChannel- , loadMoreMessages- , channelScrollToTop- , channelScrollToBottom- , channelScrollUp- , channelScrollDown- , channelPageUp- , channelPageDown- , isCurrentChannel- , isRecentChannel- , getNewMessageCutoff- , getEditedMessageCutoff- , setChannelTopic- , refreshChannelById- , refreshClientConfig- , handleChannelInvite- , addUserToCurrentChannel- , removeUserFromCurrentChannel- , createGroupChannel-- -- * Channel history- , channelHistoryForward- , channelHistoryBackward-- -- * Working with messages- , PostToAdd(..)- , sendMessage- , msgURLs- , editMessage- , deleteMessage- , addNewPostedMessage- , fetchVisibleIfNeeded-- -- * Working with users- , handleNewUsers- , handleTypingUser-- -- * Startup/reconnect management- , refreshChannelsAndUsers-- -- * Channel selection mode- , beginChannelSelect- , updateChannelSelectMatches- , channelSelectNext- , channelSelectPrevious-- -- * Server-side preferences- , applyPreferenceChange-- -- * Message selection mode- , beginMessageSelect- , flagSelectedMessage- , copyVerbatimToClipboard- , openSelectedMessageURLs- , beginConfirmDeleteSelectedMessage- , messageSelectUp- , messageSelectUpBy- , messageSelectDown- , messageSelectDownBy- , deleteSelectedMessage- , beginReplyCompose- , beginEditMessage- , getSelectedMessage- , cancelReplyOrEdit- , replyToLatestMessage-- -- * URL selection mode- , startUrlSelect- , stopUrlSelect- , openSelectedURL-- -- * Help- , showHelpScreen-- -- * Themes- , listThemes- , setTheme- )-where--import Prelude ()-import Prelude.MH--import Brick ( invalidateCacheEntry )-import Brick.Main ( getVtyHandle, viewportScroll, vScrollToBeginning, vScrollBy, vScrollToEnd )-import Brick.Themes ( themeToAttrMap )-import Brick.Widgets.Edit ( applyEdit )-import Brick.Widgets.Edit ( getEditContents, editContentsL )-import Brick.Widgets.List ( list, listMoveTo, listSelectedElement )-import Control.Concurrent ( MVar, putMVar, forkIO )-import Control.Concurrent.Async ( runConcurrently, Concurrently(..), concurrently )-import qualified Control.Concurrent.STM as STM-import Control.Exception ( SomeException, try )-import qualified Data.ByteString as BS-import Data.Char ( isAlphaNum )-import Data.Function ( on )-import qualified Data.HashMap.Strict as HM-import Data.List ( findIndex )-import Data.Maybe ( fromJust )-import qualified Data.Sequence as Seq-import qualified Data.Set as Set-import qualified Data.Text as T-import Data.Text.Zipper ( textZipper, clearZipper, insertMany, gotoEOL )-import Data.Time ( getCurrentTime )-import qualified Data.Vector as V-import Graphics.Vty ( outputIface )-import Graphics.Vty.Output.Interface ( ringTerminalBell )-import Lens.Micro.Platform-import System.Directory ( createDirectoryIfMissing )-import System.Environment.XDG.BaseDir ( getUserCacheDir )-import System.Exit ( ExitCode(..) )-import System.FilePath-import System.IO ( hGetContents, hFlush, hPutStrLn )-import System.Process ( proc, std_in, std_out, std_err, StdStream(..)- , createProcess, waitForProcess )--import qualified Network.Mattermost.Endpoints as MM-import Network.Mattermost.Lenses-import Network.Mattermost.Types--import Config-import Constants-import FilePaths-import InputHistory-import Markdown ( blockGetURLs, findVerbatimChunk )-import Themes-import TimeUtils ( justBefore, justAfter )-import Types-import Types.Common-import Zipper ( Zipper )-import qualified Zipper as Z--import State.Common-import State.Messages-import State.Setup.Threads ( updateUserStatuses )----- * Refreshing Channel Data---- | 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 :: Channel -> ChannelMember -> MH ()-refreshChannel chan member = do- let cId = getId chan- myTId <- gets myTeamId- let ourTeam = channelTeamId chan == Nothing ||- Just myTId == channelTeamId chan-- -- If this is a group channel that the user has chosen to hide or if- -- the channel is not a channel for the current session's team, ignore- -- the refresh request.- isHidden <- channelHiddenPreference cId- case isHidden || not ourTeam of- True -> return ()- False -> do- -- If this channel is unknown, register it first.- mChan <- preuse (csChannel(cId))- when (isNothing mChan) $- handleNewChannel False chan member-- updateChannelInfo cId chan member--refreshChannelById :: ChannelId -> MH ()-refreshChannelById cId = do- session <- getSession- doAsyncWith Preempt $ do- cwd <- MM.mmGetChannel cId session- member <- MM.mmGetChannelMember cId UserMe session- return $ refreshChannel cwd member--createGroupChannel :: Text -> MH ()-createGroupChannel usernameList = do- st <- use id- me <- gets myUser-- let usernames = T.words usernameList- findUserIds [] = return []- findUserIds (n:ns) = do- case userByUsername n st of- Nothing -> do- mhError $ NoSuchUser n- return []- Just u -> (u^.uiId:) <$> findUserIds ns-- results <- findUserIds usernames-- -- If we found all of the users mentioned, then create the group- -- channel.- when (length results == length usernames) $ do- session <- getSession- doAsyncWith Preempt $ do- 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.- MM.mmSaveUsersPreferences UserMe (Seq.singleton pref) session- cwd <- MM.mmGetChannel (channelId chan) session- member <- MM.mmGetChannelMember (channelId chan) UserMe session- return $ do- applyPreferenceChange pref- handleNewChannel True cwd member--channelHiddenPreference :: ChannelId -> MH Bool-channelHiddenPreference cId = do- prefs <- use (csResources.crUserPreferences.userPrefGroupChannelPrefs)- let matching = filter (\p -> fst p == cId) (HM.toList prefs)- return $ any (not . snd) matching--applyPreferenceChange :: Preference -> MH ()-applyPreferenceChange pref = do- -- always update our user preferences accordingly- csResources.crUserPreferences %= setUserPreferences (Seq.singleton pref)- if- | Just f <- preferenceToFlaggedPost pref -> do- updateMessageFlag (flaggedPostId f) (flaggedPostStatus f)- | Just g <- preferenceToGroupChannelPreference pref -> do- let cId = groupChannelId g- mChan <- preuse $ csChannel cId-- case (mChan, groupChannelShow g) of- (Just _, False) ->- -- If it has been set to hidden and we are showing it,- -- remove it from the state.- removeChannelFromState cId- (Nothing, True) ->- -- If it has been set to showing and we are not showing- -- it, ask for a load/refresh.- refreshChannelById cId- _ -> return ()- | otherwise -> return ()---- | Refresh information about all channels and users. This is usually--- triggered when a reconnect event for the WebSocket to the server--- 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 <- getSession- myTId <- gets myTeamId- doAsyncWith Preempt $ do- (chans, datas) <- runConcurrently $ (,)- <$> Concurrently (MM.mmGetChannelsForUser UserMe myTId session)- <*> Concurrently (MM.mmGetChannelMembersForUser UserMe myTId session)-- let dataMap = HM.fromList $ toList $ (\d -> (channelMemberChannelId d, d)) <$> datas- mkPair chan = (chan, fromJust $ HM.lookup (channelId chan) dataMap)- chansWithData = mkPair <$> chans-- asyncFetchAllUsers page accum final = do- doAsyncWith Preempt $ do- let pageSize = 200- userQuery = MM.defaultUserQuery- { MM.userQueryPage = Just page- , MM.userQueryPerPage = Just pageSize- , MM.userQueryInTeam = Just myTId- }- batch <- MM.mmGetUsers userQuery session-- return $ case length batch < pageSize of- True -> do- let users = accum <> batch- forM_ users $ \u -> do- when (not $ userDeleted u) $ do- result <- gets (userById (getId u))- when (isNothing result) $ handleNewUserDirect u- setUserIdSet (userId <$> users)- final- False ->- asyncFetchAllUsers (page + 1) (accum <> batch) final-- return $ do- asyncFetchAllUsers 0 mempty $ do- forM_ chansWithData $ uncurry refreshChannel- lock <- use (csResources.crUserStatusLock)- setVar <- use (csResources.crUserIdSet)- doAsyncWith Preempt $ updateUserStatuses setVar lock session---- | Refresh client-accessible server configuration information. This--- is usually triggered when a reconnect event for the WebSocket to--- the server occurs.-refreshClientConfig :: MH ()-refreshClientConfig = do- session <- getSession- doAsyncWith Preempt $ do- cfg <- MM.mmGetClientConfiguration (Just "old") session- return (csClientConfig .= Just cfg)---- | Websocket was disconnected, so all channels may now miss some--- messages-disconnectChannels :: MH ()-disconnectChannels = addDisconnectGaps---- | Update the indicated Channel entry with the new data retrieved from--- the Mattermost server. Also update the channel name if it changed.-updateChannelInfo :: ChannelId -> Channel -> ChannelMember -> MH ()-updateChannelInfo cid new member = do- mOldChannel <- preuse $ csChannel(cid)- case mOldChannel of- Nothing -> return ()- Just old ->- let oldName = old^.ccInfo.cdName- newName = preferredChannelName new- in if oldName == newName- then return ()- else do- removeChannelName oldName- addChannelName (channelType new) cid newName-- csChannel(cid).ccInfo %= channelInfoFromChannelWithData new member---- * Message selection mode--beginMessageSelect :: MH ()-beginMessageSelect = do- -- Get the number of messages in the current channel and set the- -- currently selected message index to be the most recently received- -- message that corresponds to a Post (i.e. exclude informative- -- messages).- --- -- If we can't find one at all, we ignore the mode switch request- -- and just return.- chanMsgs <- use(csCurrentChannel . ccContents . cdMessages)- let recentPost = getLatestPostMsg chanMsgs-- when (isJust recentPost) $ do- setMode MessageSelect- csMessageSelect .= MessageSelectState (join $ ((^.mPostId) <$> recentPost))--getSelectedMessage :: ChatState -> Maybe Message-getSelectedMessage st- | appMode st /= MessageSelect && appMode st /= MessageSelectDeleteConfirm = Nothing- | otherwise = do- selPostId <- selectMessagePostId $ st^.csMessageSelect-- let chanMsgs = st ^. csCurrentChannel . ccContents . cdMessages- findMessage selPostId chanMsgs--messageSelectUp :: MH ()-messageSelectUp = do- mode <- gets appMode- selected <- use (csMessageSelect.to selectMessagePostId)- case selected of- Just _ | mode == MessageSelect -> do- chanMsgs <- use (csCurrentChannel.ccContents.cdMessages)- let nextPostId = getPrevPostId selected chanMsgs- csMessageSelect .= MessageSelectState (nextPostId <|> selected)- _ -> return ()--messageSelectDown :: MH ()-messageSelectDown = do- selected <- use (csMessageSelect.to selectMessagePostId)- case selected of- Just _ -> whenMode MessageSelect $ do- chanMsgs <- use (csCurrentChannel.ccContents.cdMessages)- let nextPostId = getNextPostId selected chanMsgs- csMessageSelect .= MessageSelectState (nextPostId <|> selected)- _ -> return ()--messageSelectDownBy :: Int -> MH ()-messageSelectDownBy amt- | amt <= 0 = return ()- | otherwise =- messageSelectDown >> messageSelectDownBy (amt - 1)--messageSelectUpBy :: Int -> MH ()-messageSelectUpBy amt- | amt <= 0 = return ()- | otherwise =- messageSelectUp >> messageSelectUpBy (amt - 1)--beginConfirmDeleteSelectedMessage :: MH ()-beginConfirmDeleteSelectedMessage =- setMode MessageSelectDeleteConfirm--deleteSelectedMessage :: MH ()-deleteSelectedMessage = do- selectedMessage <- use (to getSelectedMessage)- st <- use id- cId <- use csCurrentChannelId- case selectedMessage of- Just msg | isMine st msg && isDeletable msg ->- case msg^.mOriginalPost of- Just p ->- doAsyncChannelMM Preempt cId- (\s _ _ -> MM.mmDeletePost (postId p) s)- (\_ _ -> do csEditState.cedEditMode .= NewPost- setMode Main)- Nothing -> return ()- _ -> return ()--beginCurrentChannelDeleteConfirm :: MH ()-beginCurrentChannelDeleteConfirm = do- cId <- use csCurrentChannelId- withChannel cId $ \chan -> do- let chType = chan^.ccInfo.cdType- if chType /= Direct- then setMode DeleteChannelConfirm- else mhError $ GenericError "Direct message channels cannot be deleted."--deleteCurrentChannel :: MH ()-deleteCurrentChannel = do- setMode Main- cId <- use csCurrentChannelId- leaveChannelIfPossible cId True--isCurrentChannel :: ChatState -> ChannelId -> Bool-isCurrentChannel st cId = st^.csCurrentChannelId == cId--isRecentChannel :: ChatState -> ChannelId -> Bool-isRecentChannel st cId = st^.csRecentChannel == Just cId---- | Tell the server that we have flagged or unflagged a message.-flagMessage :: PostId -> Bool -> MH ()-flagMessage pId f = do- session <- getSession- myId <- gets myUserId- doAsyncWith Normal $ do- 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--- should have its flagged state toggled.-flagSelectedMessage :: MH ()-flagSelectedMessage = do- selected <- use (to getSelectedMessage)- case selected of- Just msg- | Just pId <- msg^.mPostId ->- flagMessage pId (not (msg^.mFlagged))- _ -> return ()--beginEditMessage :: MH ()-beginEditMessage = do- selected <- use (to getSelectedMessage)- st <- use id- case selected of- Just msg | isMine st msg && isEditable msg -> do- let Just p = msg^.mOriginalPost- setMode Main- csEditState.cedEditMode .= Editing p (msg^.mType)- -- If the post that we're editing is an emote, we need- -- to strip the formatting because that's only there to- -- indicate that the post is an emote. This is annoying and- -- can go away one day when there is an actual post type- -- value of "emote" that we can look at. Note that the- -- removed formatting needs to be reinstated just prior to- -- issuing the API call to update the post.- let toEdit = if msg^.mType == CP Emote- then removeEmoteFormatting $ sanitizeUserText $ postMessage p- else sanitizeUserText $ postMessage p- csEditState.cedEditor %= applyEdit (clearZipper >> (insertMany toEdit))- _ -> return ()--removeEmoteFormatting :: T.Text -> T.Text-removeEmoteFormatting t- | "*" `T.isPrefixOf` t &&- "*" `T.isSuffixOf` t = T.init $ T.drop 1 t- | otherwise = t--addEmoteFormatting :: T.Text -> T.Text-addEmoteFormatting t = "*" <> t <> "*"--replyToLatestMessage :: MH ()-replyToLatestMessage = do- msgs <- use (csCurrentChannel . ccContents . cdMessages)- case findLatestUserMessage isReplyable msgs of- Just msg -> do let Just p = msg^.mOriginalPost- setMode Main- csEditState.cedEditMode .= Replying msg p- _ -> return ()--beginReplyCompose :: MH ()-beginReplyCompose = do- selected <- use (to getSelectedMessage)- case selected of- Nothing -> return ()- Just msg -> do- let Just p = msg^.mOriginalPost- setMode Main- csEditState.cedEditMode .= Replying msg p--cancelReplyOrEdit :: MH ()-cancelReplyOrEdit = do- mode <- use (csEditState.cedEditMode)- case mode of- NewPost -> return ()- _ -> do- csEditState.cedEditMode .= NewPost- csEditState.cedEditor %= applyEdit clearZipper--copyVerbatimToClipboard :: MH ()-copyVerbatimToClipboard = do- selectedMessage <- use (to getSelectedMessage)- case selectedMessage of- Nothing -> return ()- Just m -> case findVerbatimChunk (m^.mText) of- Nothing -> return ()- Just txt -> do- copyToClipboard txt- setMode Main---- * Joining, Leaving, and Inviting--joinChannelByName :: Text -> MH ()-joinChannelByName rawName = do- session <- getSession- tId <- gets myTeamId- doAsyncWith Preempt $ do- result <- try $ MM.mmGetChannelByName tId (trimChannelSigil rawName) session- return $ case result of- Left (_::SomeException) -> mhError $ NoSuchChannel rawName- Right chan -> joinChannel $ getId chan--startJoinChannel :: MH ()-startJoinChannel = do- session <- getSession- myTId <- gets myTeamId- 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 <- MM.mmGetPublicChannels myTId (Just start) (Just fetchCount) session- let chans = acc <> newChans- if length newChans < fetchCount- then return chans- else loop chans (start+1)- chans <- Seq.filter (\ c -> not (channelId c `elem` myChannels)) <$> loop mempty 0- let sortedChans = V.fromList $ toList $ Seq.sortBy (compare `on` channelName) chans- return $ do- csJoinChannelList .= (Just $ list JoinChannelList sortedChans 2)-- setMode JoinChannel- csJoinChannelList .= Nothing---- | If the user is not a member of the specified channel, submit a--- request to join it. Otherwise switch to the channel.-joinChannel :: ChannelId -> MH ()-joinChannel chanId = do- setMode Main- mChan <- preuse (csChannel(chanId))- case mChan of- Just _ -> setFocus chanId- Nothing -> do- myId <- gets myUserId- let member = MinChannelMember myId chanId- csLastJoinRequest .= Just chanId- doAsyncChannelMM Preempt chanId (\ 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.-handleChannelInvite :: ChannelId -> MH ()-handleChannelInvite cId = do- session <- getSession- doAsyncWith Normal $ do- member <- MM.mmGetChannelMember cId UserMe session- tryMM (MM.mmGetChannel cId session)- (\cwd -> return $ handleNewChannel False cwd member)--addUserToCurrentChannel :: Text -> MH ()-addUserToCurrentChannel uname = do- -- First: is this a valid username?- result <- gets (userByUsername uname)- case result of- Just u -> do- cId <- use csCurrentChannelId- session <- getSession- let channelMember = MinChannelMember (u^.uiId) cId- doAsyncWith Normal $ do- tryMM (void $ MM.mmAddUser cId channelMember session)- (const $ return (return ()))- _ -> do- mhError $ NoSuchUser uname--removeUserFromCurrentChannel :: Text -> MH ()-removeUserFromCurrentChannel uname = do- -- First: is this a valid username?- result <- gets (userByUsername uname)- case result of- Just u -> do- cId <- use csCurrentChannelId- session <- getSession- doAsyncWith Normal $ do- tryMM (void $ MM.mmRemoveUserFromChannel cId (UserById $ u^.uiId) session)- (const $ return (return ()))- _ -> do- mhError $ NoSuchUser uname--startLeaveCurrentChannel :: MH ()-startLeaveCurrentChannel = do- cInfo <- use (csCurrentChannel.ccInfo)- case canLeaveChannel cInfo of- True -> setMode LeaveChannelConfirm- False -> mhError $ GenericError "The /leave command cannot be used with this channel."--leaveCurrentChannel :: MH ()-leaveCurrentChannel = use csCurrentChannelId >>= leaveChannel--leaveChannelIfPossible :: ChannelId -> Bool -> MH ()-leaveChannelIfPossible cId delete = do- st <- use id- me <- gets myUser- let isMe u = u^.userIdL == me^.userIdL-- case st ^? csChannel(cId).ccInfo of- Nothing -> return ()- Just cInfo -> case canLeaveChannel cInfo of- False -> return ()- True ->- -- The server will reject an attempt to leave a private- -- channel if we're the only member. To check this, we- -- just ask for the first two members of the channel.- -- If there is only one, it must be us: hence the "all- -- isMe" check below. If there are two members, it- -- doesn't matter who they are, because we just know- -- that we aren't the only remaining member, so we can't- -- delete the channel.- doAsyncChannelMM Preempt cId- (\s _ _ ->- let query = MM.defaultUserQuery- { MM.userQueryPage = Just 0- , MM.userQueryPerPage = Just 2- , MM.userQueryInChannel = Just cId- }- in toList <$> MM.mmGetUsers query s)- (\_ members -> do- -- If the channel is private:- -- * leave it if we aren't the last member.- -- * delete it if we are.- --- -- Otherwise:- -- * leave (or delete) the channel as specified- -- by the delete argument.- let func = case cInfo^.cdType of- Private -> case all isMe members of- True -> (\ s _ c -> MM.mmDeleteChannel c s)- False -> (\ s _ c -> MM.mmRemoveUserFromChannel c UserMe s)- Group ->- \s _ _ ->- let pref = hideGroupChannelPref cId (me^.userIdL)- in MM.mmSaveUsersPreferences UserMe (Seq.singleton pref) s- _ -> if delete- then (\ s _ c -> MM.mmDeleteChannel c s)- else (\ s _ c -> MM.mmRemoveUserFromChannel c UserMe s)-- doAsyncChannelMM Preempt cId func endAsyncNOP- )--hideGroupChannelPref :: ChannelId -> UserId -> Preference-hideGroupChannelPref cId uId =- Preference { preferenceCategory = PreferenceCategoryGroupChannelShow- , preferenceValue = PreferenceValue "false"- , preferenceName = PreferenceName $ idString cId- , preferenceUserId = uId- }--showGroupChannelPref :: ChannelId -> UserId -> Preference-showGroupChannelPref cId uId =- Preference { preferenceCategory = PreferenceCategoryGroupChannelShow- , preferenceValue = PreferenceValue "true"- , preferenceName = PreferenceName $ idString cId- , preferenceUserId = uId- }--leaveChannel :: ChannelId -> MH ()-leaveChannel cId = leaveChannelIfPossible cId False--removeChannelFromState :: ChannelId -> MH ()-removeChannelFromState cId = do- withChannel cId $ \ chan -> do- let cName = chan^.ccInfo.cdName- chType = chan^.ccInfo.cdType- when (chType /= Direct) $ do- origFocus <- use csCurrentChannelId- when (origFocus == cId) nextChannel- csEditState.cedInputHistoryPosition .at cId .= Nothing- csEditState.cedLastChannelInput .at cId .= Nothing- -- Update input history- csEditState.cedInputHistory %= removeChannelHistory cId- -- Remove channel name mappings- removeChannelName cName- -- Update msgMap- csChannels %= filteredChannels ((/=) cId . fst)- -- Remove from focus zipper- csFocus %= Z.filterZipper (/= cId)---- | Called on async completion when the currently viewed channel has--- been updated (i.e., just switched to this channel) to update local--- state.-setLastViewedFor :: Maybe ChannelId -> ChannelId -> MH ()-setLastViewedFor prevId cId = do- chan <- use (csChannels.to (findChannelById cId))- -- Update new channel's viewed time, creating the channel if needed- case chan of- Nothing ->- -- It's possible for us to get spurious WMChannelViewed events- -- from the server, e.g. for channels that have been deleted.- -- So here we ignore the request since it's hard to detect it- -- before this point.- return ()- Just _ ->- -- The server has been sent a viewed POST update, but there is- -- no local information on what timestamp the server actually- -- recorded. There are a couple of options for setting the- -- local value of the viewed time:- --- -- 1. Attempting to locally construct a value, which would- -- involve scanning all (User) messages in the channel to- -- find the maximum of the created date, the modified date,- -- or the deleted date, and assuming that maximum mostly- -- matched the server's viewed time.- --- -- 2. Issuing a channel metadata request to get the server's- -- new concept of the viewed time.- --- -- 3. Having the "chan/viewed" POST that was just issued- -- return a value from the server. See- -- https://github.com/mattermost/platform/issues/6803.- --- -- Method 3 would be the best and most lightweight. Until that- -- is available, Method 2 will be used. The downside to Method- -- 2 is additional client-server messaging, and a delay in- -- 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 (\ 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 ()- Just p -> csChannels %= (channelByIdL p %~ (clearNewMessageIndicator . clearEditedThreshold))--updateViewed :: MH ()-updateViewed = do- csCurrentChannel.ccInfo.cdMentionCount .= 0- updateViewedChan =<< use csCurrentChannelId---- | When a new channel has been selected for viewing, this will--- notify the server of the change, and also update the local channel--- state to set the last-viewed time for the previous channel and--- update the viewed time to now for the newly selected channel.-updateViewedChan :: ChannelId -> MH ()-updateViewedChan cId = use csConnectionStatus >>= \case- Connected -> do- -- Only do this if we're connected to avoid triggering noisy exceptions.- pId <- use csRecentChannel- doAsyncChannelMM Preempt cId- (\s _ c -> MM.mmViewChannel UserMe c pId s)- (\c () -> setLastViewedFor pId c)- Disconnected ->- -- Cannot update server; make no local updates to avoid- -- getting out-of-sync with the server. Assumes that this- -- is a temporary break in connectivity and that after the- -- connection is restored, the user's normal activities will- -- update state as appropriate. If connectivity is- -- permanently lost, managing this state is irrelevant.- return ()--resetHistoryPosition :: MH ()-resetHistoryPosition = do- cId <- use csCurrentChannelId- csEditState.cedInputHistoryPosition.at cId .= Just Nothing--clearEditor :: MH ()-clearEditor = csEditState.cedEditor %= applyEdit clearZipper--loadLastEdit :: MH ()-loadLastEdit = do- cId <- use csCurrentChannelId- lastInput <- use (csEditState.cedLastChannelInput.at cId)- case lastInput of- Nothing -> return ()- Just (lastEdit, lastEditMode) -> do- csEditState.cedEditor %= (applyEdit $ insertMany (lastEdit) . clearZipper)- csEditState.cedEditMode .= lastEditMode--saveCurrentEdit :: MH ()-saveCurrentEdit = do- cId <- use csCurrentChannelId- cmdLine <- use (csEditState.cedEditor)- mode <- use (csEditState.cedEditMode)- csEditState.cedLastChannelInput.at cId .=- Just (T.intercalate "\n" $ getEditContents $ cmdLine, mode)--resetCurrentEdit :: MH ()-resetCurrentEdit = do- cId <- use csCurrentChannelId- csEditState.cedLastChannelInput.at cId .= Nothing--updateChannelListScroll :: MH ()-updateChannelListScroll = do- mh $ vScrollToBeginning (viewportScroll ChannelList)--postChangeChannelCommon :: MH ()-postChangeChannelCommon = do- resetHistoryPosition- resetEditorState- updateChannelListScroll- loadLastEdit- resetCurrentEdit--resetEditorState :: MH ()-resetEditorState = do- csEditState.cedEditMode .= NewPost- clearEditor--preChangeChannelCommon :: MH ()-preChangeChannelCommon = do- cId <- use csCurrentChannelId- csRecentChannel .= Just cId- saveCurrentEdit--nextChannel :: MH ()-nextChannel = do- st <- use id- setFocusWith (getNextNonDMChannel st Z.right)--prevChannel :: MH ()-prevChannel = do- st <- use id- setFocusWith (getNextNonDMChannel st Z.left)--recentChannel :: MH ()-recentChannel = do- recent <- use csRecentChannel- case recent of- Nothing -> return ()- Just cId -> setFocus cId--nextUnreadChannel :: MH ()-nextUnreadChannel = do- st <- use id- setFocusWith (getNextUnreadChannel st)--getNextNonDMChannel :: ChatState- -> (Zipper ChannelId -> Zipper ChannelId)- -> (Zipper ChannelId -> Zipper ChannelId)-getNextNonDMChannel st shift z =- if fType z == Direct- then z- else go (shift z)- where go z'- | fType z' /= Direct = z'- | otherwise = go (shift z')- fType onz = st^.(csChannels.to- (findChannelById (Z.focus onz))) ^?! _Just.ccInfo.cdType--getNextUnreadChannel :: ChatState- -> (Zipper ChannelId -> Zipper ChannelId)-getNextUnreadChannel st =- -- The next channel with unread messages must also be a channel- -- other than the current one, since the zipper may be on a channel- -- that has unread messages and will stay that way until we leave- -- it- so we need to skip that channel when doing the zipper search- -- for the next candidate channel.- Z.findRight (\cId -> hasUnread st cId && (cId /= st^.csCurrentChannelId))--listThemes :: MH ()-listThemes = do- let themeList = T.intercalate "\n\n" $- "Available built-in themes:" :- ((" " <>) <$> internalThemeName <$> internalThemes)- postInfoMessage themeList--setTheme :: Text -> MH ()-setTheme name =- case lookupTheme name of- Nothing -> listThemes- Just it -> csResources.crTheme .=- (themeToAttrMap $ internalTheme it)--channelPageUp :: MH ()-channelPageUp = do- cId <- use csCurrentChannelId- mh $ vScrollBy (viewportScroll (ChannelMessages cId)) (-1 * pageAmount)--channelPageDown :: MH ()-channelPageDown = do- cId <- use csCurrentChannelId- mh $ vScrollBy (viewportScroll (ChannelMessages cId)) pageAmount--channelScrollUp :: MH ()-channelScrollUp = do- cId <- use csCurrentChannelId- mh $ vScrollBy (viewportScroll (ChannelMessages cId)) (-1)--channelScrollDown :: MH ()-channelScrollDown = do- cId <- use csCurrentChannelId- mh $ vScrollBy (viewportScroll (ChannelMessages cId)) 1--channelScrollToTop :: MH ()-channelScrollToTop = do- cId <- use csCurrentChannelId- mh $ vScrollToBeginning (viewportScroll (ChannelMessages cId))--channelScrollToBottom :: MH ()-channelScrollToBottom = do- cId <- use csCurrentChannelId- mh $ vScrollToEnd (viewportScroll (ChannelMessages cId))---- | Fetches additional message history for the current channel. This--- is generally called when in ChannelScroll mode, in which state the--- output is cached and seen via a scrolling viewport; new messages--- received in this mode are not normally shown, but this explicit--- user-driven fetch should be displayed, so this also invalidates the--- cache.-asyncFetchMoreMessages :: MH ()-asyncFetchMoreMessages = do- cId <- use csCurrentChannelId- withChannel cId $ \chan ->- let offset = max 0 $ length (chan^.ccContents.cdMessages) - 2- -- Fetch more messages prior to any existing messages, but- -- attempt to overlap with existing messages for- -- determining contiguity or gaps. Back up two messages- -- and request from there backward, which should include- -- the last message in the response. This is an attempt- -- to fetch *more* messages, so it's expected that there- -- are at least 2 messages already here, but in case there- -- aren't, just get another page from roughly the right- -- location.- first' = splitMessagesOn (^.mPostId.to isJust) (chan^.ccContents.cdMessages)- second' = splitMessagesOn (^.mPostId.to isJust) $ snd $ snd first'- query = MM.defaultPostQuery- { MM.postQueryPage = Just (offset `div` pageAmount)- , MM.postQueryPerPage = Just pageAmount- }- & \q -> case (fst first', fst second' >>= (^.mPostId)) of- (Just _, Just i) -> q { MM.postQueryBefore = Just i- , MM.postQueryPage = Just 0- }- _ -> q- in doAsyncChannelMM Preempt cId- (\s _ c -> MM.mmGetPostsForChannel c query s)- (\c p -> do addObtainedMessages c (-pageAmount) p >>= postProcessMessageAdd- mh $ invalidateCacheEntry (ChannelMessages cId))---addNewPostedMessage :: PostToAdd -> MH ()-addNewPostedMessage p =- addMessageToState p >>= postProcessMessageAdd---addObtainedMessages :: ChannelId -> Int -> Posts -> MH PostProcessMessageAdd-addObtainedMessages cId reqCnt posts = do- -- Adding a block of server-provided messages, which are known to- -- be contiguous. Locally this may overlap with some UnknownGap- -- messages, which can therefore be removed. Alternatively the- -- new block may be discontiguous with the local blocks, in which- -- case the new block should be surrounded by UnknownGaps.- withChannelOrDefault cId NoAction $ \chan -> do- let pIdList = toList (posts^.postsOrderL)- -- the first and list PostId in the batch to be added- earliestPId = last pIdList- latestPId = head pIdList- earliestDate = postCreateAt $ (posts^.postsPostsL) HM.! earliestPId- latestDate = postCreateAt $ (posts^.postsPostsL) HM.! latestPId-- localMessages = chan^.ccContents . cdMessages-- match = snd $ removeMatchesFromSubset- (\m -> maybe False (\p -> p `elem` pIdList) (m^.mPostId))- (Just earliestPId) (Just latestPId) localMessages-- dupPIds = catMaybes $ foldr (\m l -> m^.mPostId : l) [] match-- -- If there were any matches, then there was overlap of- -- the new messages with existing messages.-- -- Don't re-add matching messages (avoid overhead like- -- re-checking/re-fetching related post information, and- -- do not signal action needed for notifications), and- -- remove any gaps in the overlapping region.-- newGapMessage d = newMessageOfType "Additional messages???" (C UnknownGap) d-- -- If this batch contains the latest known messages, do- -- not add a following gap. A gap at this point is added- -- by a websocket disconnect, and any fetches thereafter- -- are assumed to be the most current information (until- -- another disconnect), so no gap is needed.- -- Additionally, the presence of a gap at the end for a- -- connected client causes a fetch of messages at this- -- location, so adding the gap here would cause an- -- infinite update loop.-- addingAtEnd = maybe True ((<=) latestDate) $- (^.mDate) <$> getLatestPostMsg localMessages-- addingAtStart = maybe True ((>=) earliestDate) $- (^.mDate) <$> getEarliestPostMsg localMessages- removeStart = if addingAtStart && noMoreBefore then Nothing else Just earliestPId- removeEnd = if addingAtEnd then Nothing else Just latestPId-- noMoreBefore = reqCnt < 0 && length pIdList < (-reqCnt)- noMoreAfter = reqCnt > 0 && length pIdList < reqCnt-- -- The post map returned by the server will *already* have- -- all thread messages for each post that is part of a- -- thread. By calling messagesFromPosts here, we go ahead and- -- populate the csPostMap with those posts so that below, in- -- addMessageToState, we notice that we already know about reply- -- parent messages and can avoid fetching them. This converts- -- the posts to Messages and stores those and also returns- -- them, but we don't need them here. We just want the post map- -- update.- void $ messagesFromPosts posts-- -- Add all the new *unique* posts into the existing channel- -- corpus, generating needed fetches of data associated with- -- the post, and determining an notification action to be- -- taken (if any).- action <- foldr andProcessWith NoAction <$>- mapM (addMessageToState . OldPost)- [ (posts^.postsPostsL) HM.! p- | p <- toList (posts^.postsOrderL)- , not (p `elem` dupPIds)- ]-- csChannels %= modifyChannelById cId- (ccContents.cdMessages %~ (fst . removeMatchesFromSubset isGap removeStart removeEnd))-- -- Add a gap at each end of the newly fetched data, unless:- -- 1. there is an overlap- -- 2. there is no more in the indicated direction- -- a. indicated by adding messages later than any currently- -- held messages (see note above re 'addingAtEnd').- -- b. the amount returned was less than the amount requested-- unless (earliestPId `elem` dupPIds || noMoreBefore) $- let gapMsg = newGapMessage (justBefore earliestDate)- in csChannels %= modifyChannelById cId- (ccContents.cdMessages %~ addMessage gapMsg)-- unless (latestPId `elem` dupPIds || addingAtEnd || noMoreAfter) $- let gapMsg = newGapMessage (justAfter latestDate)- in csChannels %= modifyChannelById cId- (ccContents.cdMessages %~ addMessage gapMsg)-- -- Now initiate fetches for use information for any- -- as-yet-unknown users related to this new set of messages- let users = foldr (\post s -> maybe s (flip Set.insert s) (postUserId post))- Set.empty (posts^.postsPostsL)- addUnknownUsers inputUserIds = do- knownUserIds <- Set.fromList <$> gets allUserIds- let unknownUsers = Set.difference inputUserIds knownUserIds- if Set.null unknownUsers- then return ()- else handleNewUsers $ Seq.fromList $ toList unknownUsers-- addUnknownUsers users-- -- Return the aggregated user notification action needed- -- relative to the set of added messages.-- return action--loadMoreMessages :: MH ()-loadMoreMessages = whenMode ChannelScroll asyncFetchMoreMessages---- | This switches to the named channel or creates it if it is a missing--- but valid user channel.-changeChannel :: Text -> MH ()-changeChannel name = do- result <- gets (channelIdByName name)- user <- gets (userByUsername name)- let err = mhError $ AmbiguousName name-- case result of- (Nothing, Nothing)- -- We know about the user but there isn't already a DM- -- channel, so create one.- | Just _ <- user -> attemptCreateDMChannel name- -- There were no matches of any kind.- | otherwise -> mhError $ NoSuchChannel name- (Just cId, Nothing)- -- We matched a channel and there was an explicit sigil, so we- -- don't care about the username match.- | normalChannelSigil `T.isPrefixOf` name -> setFocus cId- -- We matched both a channel and a user, even though there is- -- no DM channel.- | Just _ <- user -> err- -- We matched a channel only.- | otherwise -> setFocus cId- (Nothing, Just cId) ->- -- We matched a user only and there is already a DM channel.- setFocus cId- (Just _, Just _) ->- -- We matched both a channel and a user.- err--setFocus :: ChannelId -> MH ()-setFocus cId = setFocusWith (Z.findRight (== cId))--setFocusWith :: (Zipper ChannelId -> Zipper ChannelId) -> MH ()-setFocusWith f = do- oldZipper <- use csFocus- let newZipper = f oldZipper- newFocus = Z.focus newZipper- oldFocus = Z.focus oldZipper-- -- If we aren't changing anything, skip all the book-keeping because- -- we'll end up clobbering things like csRecentChannel.- when (newFocus /= oldFocus) $ do- preChangeChannelCommon- csFocus .= newZipper- updateViewed- postChangeChannelCommon--attemptCreateDMChannel :: Text -> MH ()-attemptCreateDMChannel name = do- mCid <- gets (channelIdByUsername name)- me <- gets myUser- displayNick <- use (to useNickname)- uList <- use (to sortedUserList)- let myName = if displayNick && not (T.null $ sanitizeUserText $ userNickname me)- then sanitizeUserText $ userNickname me- else me^.userUsernameL- when (name /= myName) $ do- let uName = if displayNick- then- maybe name (view uiName)- $ findUserByNickname uList name- else name- mUid <- gets (userIdForUsername uName)- if isJust mUid && isNothing mCid- then do- -- We have a user of that name but no channel. Time to make one!- let Just uId = mUid- myId <- gets myUserId- session <- getSession- doAsyncWith Normal $ do- -- create a new channel- 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- mhError $ NoSuchUser name--createOrdinaryChannel :: Text -> MH ()-createOrdinaryChannel name = do- session <- getSession- myTId <- gets myTeamId- doAsyncWith Preempt $ do- -- create a new chat channel- let slug = T.map (\ c -> if isAlphaNum c then c else '-') (T.toLower name)- minChannel = MinChannel- { minChannelName = slug- , minChannelDisplayName = name- , minChannelPurpose = Nothing- , minChannelHeader = Nothing- , minChannelType = Ordinary- , minChannelTeamId = myTId- }- tryMM (do c <- MM.mmCreateChannel minChannel session- chan <- MM.mmGetChannel (getId c) session- member <- MM.mmGetChannelMember (getId c) UserMe session- return (chan, member)- )- (return . uncurry (handleNewChannel True))--handleNewChannel :: Bool -> Channel -> ChannelMember -> MH ()-handleNewChannel = handleNewChannel_ True--handleNewChannel_ :: Bool- -- ^ Whether to permit this call to recursively- -- schedule itself for later if it can't locate- -- a DM channel user record. This is to prevent- -- uncontrolled recursion.- -> Bool- -- ^ Whether to switch to the new channel once it has- -- been installed.- -> Channel- -- ^ The channel to install.- -> ChannelMember- -> MH ()-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- Just _ -> when switch $ setFocus (getId nc)- Nothing -> do- -- Create a new ClientChannel structure- cChannel <- (ccInfo %~ channelInfoFromChannelWithData nc member) <$>- makeClientChannel nc-- st <- use id-- -- Add it to the message map, and to the name map so we can look- -- it up by name. The name we use for the channel depends on its- -- type:- let chType = nc^.channelTypeL-- -- Get the channel name. If we couldn't, that means we have- -- async work to do before we can register this channel (in- -- which case abort because we got rescheduled).- mName <- case chType of- Direct -> case userIdForDMChannel (myUserId st) (sanitizeUserText $ channelName nc) of- -- If this is a direct channel but we can't extract a- -- user ID from the name, then it failed to parse. We- -- need to assign a channel name in our channel map,- -- and the best we can do to preserve uniqueness is to- -- use the channel name string. This is undesirable- -- but direct channels never get rendered directly;- -- they only get used by first looking up usernames.- -- So this name should never appear anywhere, but at- -- least we can go ahead and register the channel and- -- handle events for it. That isn't very useful but it's- -- probably better than ignoring this entirely.- Nothing -> return $ Just $ sanitizeUserText $ channelName nc- Just otherUserId ->- case usernameForUserId otherUserId st of- -- If we found a user ID in the channel name- -- string but don't have that user's metadata,- -- postpone adding this channel until we have- -- fetched the metadata. This can happen when- -- we have a channel record for a user that- -- is no longer in the current team. To avoid- -- recursion due to a problem, ensure that- -- the rescheduled new channel handler is not- -- permitted to try this again.- --- -- If we're already in a recursive attempt to- -- register this channel and still couldn't find- -- a username, just bail and use the synthetic- -- name (this has the same problems as above).- Nothing -> do- case permitPostpone of- False -> return $ Just $ sanitizeUserText $ channelName nc- True -> do- handleNewUsers $ Seq.singleton otherUserId- doAsyncWith Normal $- return $ handleNewChannel_ False switch nc member- return Nothing- Just ncUsername ->- return $ Just $ ncUsername- _ -> return $ Just $ preferredChannelName nc-- case mName of- Nothing -> return ()- Just name -> do- addChannelName chType (getId nc) name-- csChannels %= addChannel (getId nc) cChannel-- refreshChannelZipper-- -- Finally, set our focus to the newly created channel- -- if the caller requested a change of channel. Also- -- consider the last join request state field in case- -- this is an asynchronous channel addition triggered by- -- a /join.- lastReq <- use csLastJoinRequest- wasLast <- case lastReq of- Just cId | cId == getId nc -> do- csLastJoinRequest .= Nothing- return True- _ -> return False-- when (switch || wasLast) $ setFocus (getId nc)--editMessage :: Post -> MH ()-editMessage new = do- myId <- gets myUserId- let isEditedMessage m = m^.mPostId == Just (new^.postIdL)- msg = clientPostToMessage (toClientPost new (new^.postParentIdL))- chan = csChannel (new^.postChannelIdL)- chan . ccContents . cdMessages . traversed . filtered isEditedMessage .= msg-- when (postUserId new /= Just myId) $- chan %= adjustEditedThreshold new-- csPostMap.ix(postId new) .= msg- asyncFetchReactionsForPost (postChannelId new) new- asyncFetchAttachments new- cId <- use csCurrentChannelId- when (postChannelId new == cId) updateViewed--deleteMessage :: Post -> MH ()-deleteMessage new = do- let isDeletedMessage m = m^.mPostId == Just (new^.postIdL) ||- isReplyTo (new^.postIdL) m- chan :: Traversal' ChatState ClientChannel- chan = csChannel (new^.postChannelIdL)- chan.ccContents.cdMessages.traversed.filtered isDeletedMessage %= (& mDeleted .~ True)- chan %= adjustUpdated new- cId <- use csCurrentChannelId- when (postChannelId new == cId) updateViewed--maybePostUsername :: ChatState -> Post -> T.Text-maybePostUsername st p =- fromMaybe T.empty $ do- uId <- postUserId p- usernameForUserId uId st--runNotifyCommand :: Post -> Bool -> MH ()-runNotifyCommand post mentioned = do- outputChan <- use (csResources.crSubprocessLog)- st <- use id- notifyCommand <- use (csResources.crConfiguration.to configActivityNotifyCommand)- case notifyCommand of- Nothing -> return ()- Just cmd ->- doAsyncWith Preempt $ do- let messageString = T.unpack $ sanitizeUserText $ postMessage post- notified = if mentioned then "1" else "2"- sender = T.unpack $ maybePostUsername st post- runLoggedCommand False outputChan (T.unpack cmd)- [notified, sender, messageString] Nothing Nothing- return $ return ()--maybeNotify :: PostToAdd -> MH ()-maybeNotify (OldPost _) = do- return ()-maybeNotify (RecentPost post mentioned) = runNotifyCommand post mentioned---maybeRingBell :: MH ()-maybeRingBell = do- doBell <- use (csResources.crConfiguration.to configActivityBell)- when doBell $ do- vty <- mh getVtyHandle- liftIO $ ringTerminalBell $ outputIface vty---- | PostProcessMessageAdd is an internal value that informs the main--- code whether the user should be notified (e.g., ring the bell) or--- the server should be updated (e.g., that the channel has been--- viewed). This is a monoid so that it can be folded over when there--- are multiple inbound posts to be processed.-data PostProcessMessageAdd = NoAction- | NotifyUser [PostToAdd]- | UpdateServerViewed- | NotifyUserAndServer [PostToAdd]--andProcessWith- :: PostProcessMessageAdd -> PostProcessMessageAdd -> PostProcessMessageAdd-andProcessWith NoAction x = x-andProcessWith x NoAction = x-andProcessWith (NotifyUserAndServer p) UpdateServerViewed = NotifyUserAndServer p-andProcessWith (NotifyUserAndServer p1) (NotifyUser p2) = NotifyUserAndServer (p1 <> p2)-andProcessWith (NotifyUserAndServer p1) (NotifyUserAndServer p2) = NotifyUserAndServer (p1 <> p2)-andProcessWith (NotifyUser p1) (NotifyUserAndServer p2) = NotifyUser (p1 <> p2)-andProcessWith (NotifyUser p1) (NotifyUser p2) = NotifyUser (p1 <> p2)-andProcessWith (NotifyUser p) UpdateServerViewed = NotifyUserAndServer p-andProcessWith UpdateServerViewed UpdateServerViewed = UpdateServerViewed-andProcessWith UpdateServerViewed (NotifyUserAndServer p) = NotifyUserAndServer p-andProcessWith UpdateServerViewed (NotifyUser p) = NotifyUserAndServer p---- | postProcessMessageAdd performs the actual actions indicated by--- the corresponding input value.-postProcessMessageAdd :: PostProcessMessageAdd -> MH ()-postProcessMessageAdd ppma = postOp ppma- where- postOp NoAction = return ()- postOp UpdateServerViewed = updateViewed- postOp (NotifyUser p) = maybeRingBell >> mapM_ maybeNotify p- postOp (NotifyUserAndServer p) = updateViewed >> maybeRingBell >> mapM_ maybeNotify p---- | When we add posts to the application state, we either get them--- from the server during scrollback fetches (here called 'OldPost') or--- we get them from websocket events when they are posted in real time--- (here called 'RecentPost').-data PostToAdd =- OldPost Post- -- ^ A post from the server's history- | RecentPost Post Bool- -- ^ A message posted to the channel since the user connected, along- -- with a flag indicating whether the post triggered any of the- -- user's mentions. We need an extra flag because the server- -- determines whether the post has any mentions, and that data is- -- only available in websocket events (and then provided to this- -- constructor).---- | Adds a possibly new message to the associated channel contents.--- Returns an indicator of whether the user should be potentially--- notified of a change (a new message not posted by this user, a--- mention of the user, etc.). This operation has no effect on any--- existing UnknownGap entries and should be called when those are--- irrelevant.-addMessageToState :: PostToAdd -> MH PostProcessMessageAdd-addMessageToState newPostData = do- let (new, wasMentioned) = case newPostData of- -- A post from scrollback history has no mention data, and- -- that's okay: we only need to track mentions to tell the user- -- that recent posts contained mentions.- OldPost p -> (p, False)- RecentPost p m -> (p, m)-- st <- use id- case st ^? csChannel(postChannelId new) of- Nothing -> do- session <- getSession- doAsyncWith Preempt $ do- nc <- MM.mmGetChannel (postChannelId new) session- member <- MM.mmGetChannelMember (postChannelId new) UserMe session-- let chType = nc^.channelTypeL- pref = showGroupChannelPref (postChannelId new) (myUserId st)-- -- If the channel has been archived, we don't want to post- -- this message or add the channel to the state.- case channelDeleted nc of- True -> return $ return ()- False -> return $ do- -- If the incoming message is for a group channel- -- we don't know about, that's because it was- -- previously hidden by the user. We need to- -- show it, and to do that we need to update- -- the server-side preference. (That, in turn,- -- triggers a channel refresh.)- if chType == Group- then applyPreferenceChange pref- else refreshChannel nc member-- addMessageToState newPostData >>= postProcessMessageAdd-- return NoAction- Just _ -> do- let cp = toClientPost new (new^.postParentIdL)- fromMe = (cp^.cpUser == (Just $ myUserId st)) &&- (isNothing $ cp^.cpUserOverride)- userPrefs = st^.csResources.crUserPreferences- isJoinOrLeave = case cp^.cpType of- Join -> True- Leave -> True- _ -> False- ignoredJoinLeaveMessage =- not (userPrefs^.userPrefShowJoinLeave) && isJoinOrLeave- cId = postChannelId new-- doAddMessage = do- currCId <- use csCurrentChannelId- flags <- use (csResources.crFlaggedPosts)- let msg' = clientPostToMessage cp- & mFlagged .~ ((cp^.cpPostId) `Set.member` flags)- csPostMap.at(postId new) .= Just msg'- csChannels %= modifyChannelById cId- ((ccContents.cdMessages %~ addMessage msg') .- (adjustUpdated new) .- (\c -> if currCId == cId- then c- else updateNewMessageIndicator new c) .- (\c -> if wasMentioned- then c & ccInfo.cdMentionCount %~ succ- else c)- )- asyncFetchReactionsForPost cId new- asyncFetchAttachments new- postedChanMessage-- doHandleAddedMessage = do- -- If the message is in reply to another message,- -- try to find it in the scrollback for the post's- -- channel. If the message isn't there, fetch it. If- -- we have to fetch it, don't post this message to the- -- channel until we have fetched the parent.- case cp^.cpInReplyToPost of- Just parentId ->- case getMessageForPostId st parentId of- Nothing -> do- doAsyncChannelMM Preempt cId- (\s _ _ -> MM.mmGetThread parentId s)- (\_ p -> do- let postMap = HM.fromList [ ( pId- , clientPostToMessage- (toClientPost x (x^.postParentIdL))- )- | (pId, x) <- HM.toList (p^.postsPostsL)- ]- csPostMap %= HM.union postMap- )- _ -> return ()- _ -> return ()-- doAddMessage-- postedChanMessage =- withChannelOrDefault (postChannelId new) NoAction $ \chan -> do- currCId <- use csCurrentChannelId-- let notifyPref = notifyPreference (myUser st) chan- curChannelAction = if postChannelId new == currCId- then UpdateServerViewed- else NoAction- originUserAction =- if | fromMe -> NoAction- | ignoredJoinLeaveMessage -> NoAction- | notifyPref == NotifyOptionAll -> NotifyUser [newPostData]- | notifyPref == NotifyOptionMention- && wasMentioned -> NotifyUser [newPostData]- | otherwise -> NoAction-- return $ curChannelAction `andProcessWith` originUserAction-- doHandleAddedMessage--getNewMessageCutoff :: ChannelId -> ChatState -> Maybe NewMessageIndicator-getNewMessageCutoff cId st = do- cc <- st^?csChannel(cId)- return $ cc^.ccInfo.cdNewMessageIndicator--getEditedMessageCutoff :: ChannelId -> ChatState -> Maybe ServerTime-getEditedMessageCutoff cId st = do- cc <- st^?csChannel(cId)- cc^.ccInfo.cdEditedMessageThreshold---fetchVisibleIfNeeded :: MH ()-fetchVisibleIfNeeded = do- sts <- use csConnectionStatus- case sts of- Connected -> do- cId <- use csCurrentChannelId- withChannel cId $ \chan ->- let msgs = chan^.ccContents.cdMessages.to reverseMessages- (numRemaining, gapInDisplayable, _, rel'pId, overlap) =- foldl gapTrail (numScrollbackPosts, False, Nothing, Nothing, 2) msgs- gapTrail a@(_, True, _, _, _) _ = a- gapTrail a@(0, _, _, _, _) _ = a- gapTrail (a, False, b, c, d) m | isGap m = (a, True, b, c, d)- gapTrail (remCnt, _, prev'pId, prev''pId, ovl) msg =- (remCnt - 1, False, msg^.mPostId <|> prev'pId, prev'pId <|> prev''pId,- ovl + if isNothing (msg^.mPostId) then 1 else 0)- numToReq = numRemaining + overlap- query = MM.defaultPostQuery- { MM.postQueryPage = Just 0- , MM.postQueryPerPage = Just numToReq- }- finalQuery = case rel'pId of- Nothing -> query- Just pid -> query { MM.postQueryBefore = Just pid }- op = \s _ c -> MM.mmGetPostsForChannel c finalQuery s- in when ((not $ chan^.ccContents.cdFetchPending) && gapInDisplayable) $ do- csChannel(cId).ccContents.cdFetchPending .= True- doAsyncChannelMM Preempt cId op- (\c p -> do addObtainedMessages c (-numToReq) p >>= postProcessMessageAdd- csChannel(c).ccContents.cdFetchPending .= False)-- _ -> return ()--setChannelTopic :: Text -> MH ()-setChannelTopic msg = do- cId <- use csCurrentChannelId- let patch = defaultChannelPatch { channelPatchHeader = Just msg }- doAsyncChannelMM Preempt cId- (\s _ _ -> MM.mmPatchChannel cId patch s)- (\_ _ -> return ())--channelHistoryForward :: MH ()-channelHistoryForward = do- cId <- use csCurrentChannelId- inputHistoryPos <- use (csEditState.cedInputHistoryPosition.at cId)- inputHistory <- use (csEditState.cedInputHistory)- case inputHistoryPos of- Just (Just i)- | i == 0 -> do- -- Transition out of history navigation- csEditState.cedInputHistoryPosition.at cId .= Just Nothing- loadLastEdit- | otherwise -> do- let Just entry = getHistoryEntry cId newI inputHistory- newI = i - 1- eLines = T.lines entry- mv = if length eLines == 1 then gotoEOL else id- csEditState.cedEditor.editContentsL .= (mv $ textZipper eLines Nothing)- csEditState.cedInputHistoryPosition.at cId .= (Just $ Just newI)- _ -> return ()--channelHistoryBackward :: MH ()-channelHistoryBackward = do- cId <- use csCurrentChannelId- inputHistoryPos <- use (csEditState.cedInputHistoryPosition.at cId)- inputHistory <- use (csEditState.cedInputHistory)- case inputHistoryPos of- Just (Just i) ->- let newI = i + 1- in case getHistoryEntry cId newI inputHistory of- Nothing -> return ()- Just entry -> do- let eLines = T.lines entry- mv = if length eLines == 1 then gotoEOL else id- csEditState.cedEditor.editContentsL .= (mv $ textZipper eLines Nothing)- csEditState.cedInputHistoryPosition.at cId .= (Just $ Just newI)- _ ->- let newI = 0- in case getHistoryEntry cId newI inputHistory of- Nothing -> return ()- Just entry ->- let eLines = T.lines entry- mv = if length eLines == 1 then gotoEOL else id- in do- saveCurrentEdit- csEditState.cedEditor.editContentsL .= (mv $ textZipper eLines Nothing)- csEditState.cedInputHistoryPosition.at cId .= (Just $ Just newI)--showHelpScreen :: HelpTopic -> MH ()-showHelpScreen topic = do- mh $ vScrollToBeginning (viewportScroll HelpViewport)- setMode $ ShowHelp topic--beginChannelSelect :: MH ()-beginChannelSelect = do- setMode ChannelSelect- csChannelSelectState .= emptyChannelSelectState---- Select the next match in channel selection mode.-channelSelectNext :: MH ()-channelSelectNext = updateSelectedMatch succ---- Select the previous match in channel selection mode.-channelSelectPrevious :: MH ()-channelSelectPrevious = updateSelectedMatch pred---- Update the channel selection mode match cursor. The argument function--- determines how the new cursor position is computed from the old--- one. The new cursor position is automatically wrapped around to the--- beginning or end of the channel selection match list, so cursor--- transformations do not have to do index validation. If the current--- match (e.g. the sentinel "") is not found in the match list, this--- sets the cursor position to the first match, if any.-updateSelectedMatch :: (Int -> Int) -> MH ()-updateSelectedMatch nextIndex = do- chanMatches <- use (csChannelSelectState.channelMatches)- usernameMatches <- use (csChannelSelectState.userMatches)-- csChannelSelectState.selectedMatch %= \oldMatch ->- -- Make the list of all matches, in display order.- let allMatches = concat [ (ChannelMatch . matchFull) <$> chanMatches- , (UserMatch . matchFull) <$> usernameMatches- ]- defaultMatch = if null allMatches- then Nothing- else Just $ allMatches !! 0- in case oldMatch of- Nothing -> defaultMatch- Just oldMatch' -> case findIndex (== oldMatch') allMatches of- Nothing -> defaultMatch- Just i ->- let newIndex = if tmpIndex < 0- then length allMatches - 1- else if tmpIndex >= length allMatches- then 0- else tmpIndex- tmpIndex = nextIndex i- in Just $ allMatches !! newIndex--updateChannelSelectMatches :: MH ()-updateChannelSelectMatches = do- -- Given the current channel select string, find all the channel and- -- user matches and then update the match lists.- input <- use (csChannelSelectState.channelSelectInput)- let pat = parseChannelSelectPattern input- chanNameMatches = case pat of- Nothing -> const Nothing- Just p -> if T.null input- then const Nothing- else applySelectPattern p- patTy = case pat of- Nothing -> Nothing- Just (CSP ty _) -> Just ty-- chanNames <- gets (sort . allChannelNames)- uList <- use (to sortedUserList)- displayNick <- use (to useNickname)- let chanMatches = if patTy == Just UsersOnly- then mempty- else catMaybes (fmap chanNameMatches chanNames)- displayName uInf- | displayNick = uInf^.uiNickName.non (uInf^.uiName)- | otherwise = uInf^.uiName- usernameMatches = if patTy == Just ChannelsOnly- then mempty- else catMaybes (fmap (chanNameMatches . displayName) uList)-- newInput <- use (csChannelSelectState.channelSelectInput)- csChannelSelectState.channelMatches .= chanMatches- csChannelSelectState.userMatches .= usernameMatches- csChannelSelectState.selectedMatch %= \oldMatch ->- -- If the user input exactly matches one of the matches, prefer- -- that one. Otherwise, if the previously selected match is- -- still a possible match, leave it selected. Otherwise revert- -- to the first available match.- let unames = matchFull <$> usernameMatches- cnames = matchFull <$> chanMatches- firstAvailableMatch =- if null chanMatches- then if null unames- then Nothing- else Just $ UserMatch $ head unames- else Just $ ChannelMatch $ head cnames- newMatch = case oldMatch of- Just (UserMatch u) ->- if newInput `elem` unames- then Just $ UserMatch newInput- else if u `elem` unames- then oldMatch- else firstAvailableMatch- Just (ChannelMatch c) ->- if newInput `elem` cnames- then Just $ ChannelMatch $ newInput- else if c `elem` cnames- then oldMatch- else firstAvailableMatch- Nothing -> firstAvailableMatch- in newMatch--applySelectPattern :: ChannelSelectPattern -> Text -> Maybe ChannelSelectMatch-applySelectPattern (CSP ty pat) chanName = do- let applyType Infix | pat `T.isInfixOf` chanName =- case T.breakOn pat chanName of- (pre, post) -> return (pre, pat, T.drop (T.length pat) post)-- applyType Prefix | pat `T.isPrefixOf` chanName = do- let (b, a) = T.splitAt (T.length pat) chanName- return ("", b, a)-- applyType UsersOnly | pat `T.isPrefixOf` chanName = do- let (b, a) = T.splitAt (T.length pat) chanName- return ("", b, a)-- applyType ChannelsOnly | pat `T.isPrefixOf` chanName = do- let (b, a) = T.splitAt (T.length pat) chanName- return ("", b, a)-- applyType Suffix | pat `T.isSuffixOf` chanName = do- let (b, a) = T.splitAt (T.length chanName - T.length pat) chanName- return (b, a, "")-- applyType Equal | pat == chanName =- return ("", chanName, "")-- applyType _ = Nothing-- (pre, m, post) <- applyType ty- return $ ChannelSelectMatch pre m post chanName--parseChannelSelectPattern :: Text -> Maybe ChannelSelectPattern-parseChannelSelectPattern pat = do- let only = if | userSigil `T.isPrefixOf` pat -> Just $ CSP UsersOnly $ T.tail pat- | normalChannelSigil `T.isPrefixOf` pat -> Just $ CSP ChannelsOnly $ T.tail pat- | otherwise -> Nothing-- (pat1, pfx) <- case "^" `T.isPrefixOf` pat of- True -> return (T.tail pat, Just Prefix)- False -> return (pat, Nothing)-- (pat2, sfx) <- case "$" `T.isSuffixOf` pat1 of- True -> return (T.init pat1, Just Suffix)- False -> return (pat1, Nothing)-- only <|> case (pfx, sfx) of- (Nothing, Nothing) -> return $ CSP Infix pat2- (Just Prefix, Nothing) -> return $ CSP Prefix pat2- (Nothing, Just Suffix) -> return $ CSP Suffix pat2- (Just Prefix, Just Suffix) -> return $ CSP Equal pat2- tys -> error $ "BUG: invalid channel select case: " <> show tys--startUrlSelect :: MH ()-startUrlSelect = do- urls <- use (csCurrentChannel.to findUrls.to V.fromList)- setMode UrlSelect- csUrlList .= (listMoveTo (length urls - 1) $ list UrlList urls 2)--stopUrlSelect :: MH ()-stopUrlSelect = setMode Main--findUrls :: ClientChannel -> [LinkChoice]-findUrls chan =- let msgs = chan^.ccContents.cdMessages- in removeDuplicates $ concat $ toList $ toList <$> msgURLs <$> msgs---- XXX: move this somewhere more sensible!---- | The 'nubOn' function removes duplicate elements from a list. In--- particular, it keeps only the /last/ occurrence of each--- element. The equality of two elements in a call to @nub f@ is--- determined using @f x == f y@, and the resulting elements must have--- an 'Ord' instance in order to make this function more efficient.-nubOn :: (Ord b) => (a -> b) -> [a] -> [a]-nubOn f = snd . go Set.empty- where go before [] = (before, [])- go before (x:xs) =- let (before', xs') = go before xs- key = f x in- if key `Set.member` before'- then (before', xs')- else (Set.insert key before', x : xs')--removeDuplicates :: [LinkChoice] -> [LinkChoice]-removeDuplicates = nubOn (\ l -> (l^.linkURL, l^.linkUser))--msgURLs :: Message -> Seq LinkChoice-msgURLs msg- | NoUser <- msg^.mUser = mempty- | otherwise =- let uid = msg^.mUser- msgUrls = (\ (url, text) -> LinkChoice (msg^.mDate) uid text url Nothing) <$>- (mconcat $ blockGetURLs <$> (toList $ msg^.mText))- attachmentURLs = (\ a ->- LinkChoice- (msg^.mDate)- uid- ("attachment `" <> (a^.attachmentName) <> "`")- (a^.attachmentURL)- (Just (a^.attachmentFileId)))- <$> (msg^.mAttachments)- in msgUrls <> attachmentURLs--openSelectedURL :: MH ()-openSelectedURL = whenMode UrlSelect $ do- selected <- use (csUrlList.to listSelectedElement)- case selected of- Nothing -> return ()- Just (_, link) -> do- opened <- openURL link- when (not opened) $ do- mhError $ ConfigOptionMissing "urlOpenCommand"- setMode Main--openURL :: LinkChoice -> MH Bool-openURL link = do- cfg <- use (csResources.crConfiguration)- case configURLOpenCommand cfg of- Nothing ->- return False- Just urlOpenCommand -> do- session <- getSession-- -- Is the URL referring to an attachment?- let act = case link^.linkFileId of- Nothing -> prepareLink link- Just fId -> prepareAttachment fId session-- -- Is the URL-opening command interactive? If so, pause- -- Matterhorn and run the opener interactively. Otherwise- -- run the opener asynchronously and continue running- -- Matterhorn interactively.- case configURLOpenCommandInteractive cfg of- False -> do- outputChan <- use (csResources.crSubprocessLog)- doAsyncWith Preempt $ do- args <- act- runLoggedCommand False outputChan (T.unpack urlOpenCommand)- args Nothing Nothing- return $ return ()- True -> do- -- If there isn't a new message cutoff showing in- -- the current channel, set one. This way, while the- -- user is gone using their interactive URL opener,- -- when they return, any messages that arrive in the- -- current channel will be displayed as new.- curChan <- use csCurrentChannel- let msgs = curChan^.ccContents.cdMessages- case findLatestUserMessage isEditable msgs of- Nothing -> return ()- Just m ->- case m^.mOriginalPost of- Nothing -> return ()- Just p ->- case curChan^.ccInfo.cdNewMessageIndicator of- Hide ->- csCurrentChannel.ccInfo.cdNewMessageIndicator .= (NewPostsAfterServerTime (p^.postCreateAtL))- _ -> return ()- -- No need to add a gap here: the websocket- -- disconnect/reconnect events will automatically- -- handle management of messages delivered while- -- suspended.-- mhSuspendAndResume $ \st -> do- args <- act- void $ runInteractiveCommand (T.unpack urlOpenCommand) args- return $ setMode' Main st-- return True--prepareLink :: LinkChoice -> IO [String]-prepareLink link = return [T.unpack $ link^.linkURL]--prepareAttachment :: FileId -> Session -> IO [String]-prepareAttachment fId sess = do- -- The link is for an attachment, so fetch it and then- -- open the local copy.-- (info, contents) <- concurrently (MM.mmGetMetadataForFile fId sess) (MM.mmGetFile fId sess)- cacheDir <- getUserCacheDir xdgName-- let dir = cacheDir </> "files" </> T.unpack (idString fId)- fname = dir </> T.unpack (fileInfoName info)-- createDirectoryIfMissing True dir- BS.writeFile fname contents- return [fname]--runInteractiveCommand :: String- -> [String]- -> IO (Either String ExitCode)-runInteractiveCommand cmd args = do- let opener = (proc cmd args) { std_in = Inherit- , std_out = Inherit- , std_err = Inherit- }- result <- try $ createProcess opener- case result of- Left (e::SomeException) -> return $ Left $ show e- Right (_, _, _, ph) -> do- ec <- waitForProcess ph- return $ Right ec--runLoggedCommand :: Bool- -- ^ Whether stdout output is expected for this program- -> STM.TChan ProgramOutput- -- ^ The output channel to send the output to- -> String- -- ^ The program name- -> [String]- -- ^ Arguments- -> Maybe String- -- ^ The stdin to send, if any- -> Maybe (MVar ProgramOutput)- -- ^ Where to put the program output when it is ready- -> IO ()-runLoggedCommand stdoutOkay outputChan cmd args mInput mOutputVar = void $ forkIO $ do- let stdIn = maybe NoStream (const CreatePipe) mInput- opener = (proc cmd args) { std_in = stdIn- , std_out = CreatePipe- , std_err = CreatePipe- }- result <- try $ createProcess opener- case result of- Left (e::SomeException) -> do- let po = ProgramOutput cmd args "" stdoutOkay (show e) (ExitFailure 1)- STM.atomically $ STM.writeTChan outputChan po- maybe (return ()) (flip putMVar po) mOutputVar- Right (stdinResult, Just outh, Just errh, ph) -> do- case stdinResult of- Just inh -> do- let Just input = mInput- hPutStrLn inh input- hFlush inh- Nothing -> return ()-- ec <- waitForProcess ph- outResult <- hGetContents outh- errResult <- hGetContents errh- let po = ProgramOutput cmd args outResult stdoutOkay errResult ec- STM.atomically $ STM.writeTChan outputChan po- maybe (return ()) (flip putMVar po) mOutputVar- Right _ ->- error $ "BUG: createProcess returned unexpected result, report this at " <>- "https://github.com/matterhorn-chat/matterhorn"--openSelectedMessageURLs :: MH ()-openSelectedMessageURLs = whenMode MessageSelect $ do- Just curMsg <- use (to getSelectedMessage)- let urls = msgURLs curMsg- when (not (null urls)) $ do- openedAll <- and <$> mapM openURL urls- case openedAll of- True -> setMode Main- False ->- mhError $ ConfigOptionMissing "urlOpenCommand"--shouldSkipMessage :: Text -> Bool-shouldSkipMessage "" = True-shouldSkipMessage s = T.all (`elem` (" \t"::String)) s--sendMessage :: EditMode -> Text -> MH ()-sendMessage mode msg =- case shouldSkipMessage msg of- True -> return ()- False -> do- status <- use csConnectionStatus- st <- use id- case status of- Disconnected -> do- let m = "Cannot send messages while disconnected."- mhError $ GenericError m- Connected -> do- let chanId = st^.csCurrentChannelId- session <- getSession- doAsync Preempt $ do- case mode of- NewPost -> do- let pendingPost = rawPost msg chanId- void $ MM.mmCreatePost pendingPost session- Replying _ p -> do- let pendingPost = (rawPost msg chanId) { rawPostRootId = postRootId p <|> (Just $ postId p) }- void $ MM.mmCreatePost pendingPost session- Editing p ty -> do- let body = if ty == CP Emote- then addEmoteFormatting msg- else msg- void $ MM.mmPatchPost (postId p) (postUpdateBody body) session--handleNewUserDirect :: User -> MH ()-handleNewUserDirect newUser = do- let usrInfo = userInfoFromUser newUser True- addNewUser usrInfo--handleNewUsers :: Seq UserId -> MH ()-handleNewUsers newUserIds = doAsyncMM Preempt getUserInfo addNewUsers- where getUserInfo session _ =- do nUsers <- MM.mmGetUsersByIds newUserIds session- let usrInfo u = userInfoFromUser u True- usrList = toList nUsers- return $ usrInfo <$> usrList-- addNewUsers :: [UserInfo] -> MH ()- addNewUsers = mapM_ addNewUser---- | 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/Async.hs view
@@ -0,0 +1,162 @@+module State.Async+ ( AsyncPriority(..)+ , doAsync+ , doAsyncIO+ , doAsyncWith+ , doAsyncChannelMM+ , doAsyncWithIO+ , doAsyncMM+ , tryMM+ , endAsyncNOP+ )+where++import Prelude ()+import Prelude.MH++import qualified Control.Concurrent.STM as STM+import Control.Exception ( try )++import Network.Mattermost.Types++import Types+++-- | Try to run a computation, posting an informative error+-- message if it fails with a 'MattermostServerError'.+tryMM :: IO a+ -- ^ The action to try (usually a MM API call)+ -> (a -> IO (MH ()))+ -- ^ What to do on success+ -> IO (MH ())+tryMM act onSuccess = do+ result <- liftIO $ try act+ case result of+ Left e -> return $ mhError $ ServerError e+ Right value -> liftIO $ onSuccess value++-- * Background Computation++-- $background_computation+--+-- The main context for Matterhorn is the EventM context provided by+-- the 'Brick' library. This context is normally waiting for user+-- input (or terminal resizing, etc.) which gets turned into an+-- MHEvent and the 'onEvent' event handler is called to process that+-- event, after which the display is redrawn as necessary and brick+-- awaits the next input.+--+-- However, it is often convenient to communicate with the Mattermost+-- server in the background, so that large numbers of+-- synchronously-blocking events (e.g. on startup) or refreshes can+-- occur whenever needed and without negatively impacting the UI+-- updates or responsiveness. This is handled by a 'forkIO' context+-- that waits on an STM channel for work to do, performs the work, and+-- then sends brick an MHEvent containing the completion or failure+-- information for that work.+--+-- The /doAsyncWith/ family of functions here facilitates that+-- asynchronous functionality. This is typically used in the+-- following fashion:+--+-- > doSomething :: MH ()+-- > doSomething = do+-- > got <- something+-- > doAsyncWith Normal $ do+-- > r <- mmFetchR ....+-- > return $ do+-- > csSomething.here %= processed r+--+-- The second argument is an IO monad operation (because 'forkIO' runs+-- in the IO Monad context), but it returns an MH monad operation.+-- The IO monad has access to the closure of 'doSomething' (e.g. the+-- 'got' value), but it should be aware that the state of the MH monad+-- may have been changed by the time the IO monad runs in the+-- background, so the closure is a snapshot of information at the time+-- the 'doAsyncWith' was called.+--+-- Similarly, the returned MH monad operation is *not* run in the+-- context of the 'forkIO' background, but it is instead passed via an+-- MHEvent back to the main brick thread, where it is executed in an+-- EventM handler's MH monad context. This operation therefore has+-- access to the combined closure of the pre- 'doAsyncWith' code and+-- the closure of the IO operation. It is important that the final MH+-- monad operation should *re-obtain* state information from the MH+-- monad instead of using or setting the state obtained prior to the+-- 'doAsyncWith' call.++-- | Priority setting for asynchronous work items. Preempt means that+-- the queued item will be the next work item begun (i.e. it goes to the+-- front of the queue); normal means it will go last in the queue.+data AsyncPriority = Preempt | Normal++-- | Run a computation in the background, ignoring any results from it.+doAsync :: AsyncPriority -> IO () -> MH ()+doAsync prio act = doAsyncWith prio (act >> return (return ()))++-- | Run a computation in the background, returning a computation to be+-- called on the 'ChatState' value.+doAsyncWith :: AsyncPriority -> IO (MH ()) -> MH ()+doAsyncWith prio act = do+ let putChan = case prio of+ Preempt -> STM.unGetTChan+ Normal -> STM.writeTChan+ queue <- use (csResources.crRequestQueue)+ liftIO $ STM.atomically $ putChan queue act++doAsyncIO :: AsyncPriority -> ChatState -> IO () -> IO ()+doAsyncIO prio st act =+ doAsyncWithIO prio st (act >> return (return ()))++-- | Run a computation in the background, returning a computation to be+-- called on the 'ChatState' value.+doAsyncWithIO :: AsyncPriority -> ChatState -> IO (MH ()) -> IO ()+doAsyncWithIO prio st act = do+ let putChan = case prio of+ Preempt -> STM.unGetTChan+ Normal -> STM.writeTChan+ let queue = st^.csResources.crRequestQueue+ STM.atomically $ putChan queue act++-- | Performs an asynchronous IO operation. On completion, the final+-- argument a completion function is executed in an MH () context in the+-- main (brick) thread.+doAsyncMM :: AsyncPriority+ -- ^ the priority for this async operation+ -> (Session -> TeamId -> IO a)+ -- ^ the async MM channel-based IO operation+ -> (a -> MH ())+ -- ^ function to process the results in brick event handling+ -- context+ -> MH ()+doAsyncMM prio mmOp eventHandler = do+ session <- getSession+ tId <- gets myTeamId+ doAsyncWith prio $ do+ r <- mmOp session tId+ return $ eventHandler r++-- | Helper type for a function to perform an asynchronous MM operation+-- on a channel and then invoke an MH completion event.+type DoAsyncChannelMM a =+ AsyncPriority+ -- ^ the priority for this async operation+ -> ChannelId+ -- ^ The channel+ -> (Session -> TeamId -> ChannelId -> IO a)+ -- ^ the asynchronous Mattermost channel-based IO operation+ -> (ChannelId -> a -> MH ())+ -- ^ function to process the results in brick event handling context+ -> MH ()++-- | Performs an asynchronous IO operation on a specific channel. On+-- completion, the final argument a completion function is executed in+-- an MH () context in the main (brick) thread.+doAsyncChannelMM :: DoAsyncChannelMM a+doAsyncChannelMM prio cId mmOp eventHandler =+ doAsyncMM prio (\s t -> mmOp s t cId) (eventHandler cId)++-- | Use this convenience function if no operation needs to be+-- performed in the MH state after an async operation completes.+endAsyncNOP :: ChannelId -> a -> MH ()+endAsyncNOP _ _ = return ()
+ src/State/ChannelScroll.hs view
@@ -0,0 +1,54 @@+module State.ChannelScroll+ (+ channelScrollToTop+ , channelScrollToBottom+ , channelScrollUp+ , channelScrollDown+ , channelPageUp+ , channelPageDown+ , loadMoreMessages+ )+ where++import Prelude ()+import Prelude.MH++import Brick.Main++import Constants+import State.Messages+import Types+++channelPageUp :: MH ()+channelPageUp = do+ cId <- use csCurrentChannelId+ mh $ vScrollBy (viewportScroll (ChannelMessages cId)) (-1 * pageAmount)++channelPageDown :: MH ()+channelPageDown = do+ cId <- use csCurrentChannelId+ mh $ vScrollBy (viewportScroll (ChannelMessages cId)) pageAmount++channelScrollUp :: MH ()+channelScrollUp = do+ cId <- use csCurrentChannelId+ mh $ vScrollBy (viewportScroll (ChannelMessages cId)) (-1)++channelScrollDown :: MH ()+channelScrollDown = do+ cId <- use csCurrentChannelId+ mh $ vScrollBy (viewportScroll (ChannelMessages cId)) 1++channelScrollToTop :: MH ()+channelScrollToTop = do+ cId <- use csCurrentChannelId+ mh $ vScrollToBeginning (viewportScroll (ChannelMessages cId))++channelScrollToBottom :: MH ()+channelScrollToBottom = do+ cId <- use csCurrentChannelId+ mh $ vScrollToEnd (viewportScroll (ChannelMessages cId))++loadMoreMessages :: MH ()+loadMoreMessages = whenMode ChannelScroll asyncFetchMoreMessages
+ src/State/ChannelSelect.hs view
@@ -0,0 +1,175 @@+{-# LANGUAGE MultiWayIf #-}+module State.ChannelSelect+ ( beginChannelSelect+ , updateChannelSelectMatches+ , channelSelectNext+ , channelSelectPrevious+ )+where++import Prelude ()+import Prelude.MH++import Data.List ( findIndex )+import qualified Data.Text as T+import Lens.Micro.Platform++import Types+++beginChannelSelect :: MH ()+beginChannelSelect = do+ setMode ChannelSelect+ csChannelSelectState .= emptyChannelSelectState++-- Select the next match in channel selection mode.+channelSelectNext :: MH ()+channelSelectNext = updateSelectedMatch succ++-- Select the previous match in channel selection mode.+channelSelectPrevious :: MH ()+channelSelectPrevious = updateSelectedMatch pred++updateChannelSelectMatches :: MH ()+updateChannelSelectMatches = do+ -- Given the current channel select string, find all the channel and+ -- user matches and then update the match lists.+ input <- use (csChannelSelectState.channelSelectInput)+ let pat = parseChannelSelectPattern input+ chanNameMatches = case pat of+ Nothing -> const Nothing+ Just p -> if T.null input+ then const Nothing+ else applySelectPattern p+ patTy = case pat of+ Nothing -> Nothing+ Just (CSP ty _) -> Just ty++ chanNames <- gets (sort . allChannelNames)+ uList <- use (to sortedUserList)+ displayNick <- use (to useNickname)+ let chanMatches = if patTy == Just UsersOnly+ then mempty+ else catMaybes (fmap chanNameMatches chanNames)+ displayName uInf+ | displayNick = uInf^.uiNickName.non (uInf^.uiName)+ | otherwise = uInf^.uiName+ usernameMatches = if patTy == Just ChannelsOnly+ then mempty+ else catMaybes (fmap (chanNameMatches . displayName) uList)++ newInput <- use (csChannelSelectState.channelSelectInput)+ csChannelSelectState.channelMatches .= chanMatches+ csChannelSelectState.userMatches .= usernameMatches+ csChannelSelectState.selectedMatch %= \oldMatch ->+ -- If the user input exactly matches one of the matches, prefer+ -- that one. Otherwise, if the previously selected match is+ -- still a possible match, leave it selected. Otherwise revert+ -- to the first available match.+ let unames = matchFull <$> usernameMatches+ cnames = matchFull <$> chanMatches+ firstAvailableMatch =+ if null chanMatches+ then if null unames+ then Nothing+ else Just $ UserMatch $ head unames+ else Just $ ChannelMatch $ head cnames+ newMatch = case oldMatch of+ Just (UserMatch u) ->+ if newInput `elem` unames+ then Just $ UserMatch newInput+ else if u `elem` unames+ then oldMatch+ else firstAvailableMatch+ Just (ChannelMatch c) ->+ if newInput `elem` cnames+ then Just $ ChannelMatch $ newInput+ else if c `elem` cnames+ then oldMatch+ else firstAvailableMatch+ Nothing -> firstAvailableMatch+ in newMatch++applySelectPattern :: ChannelSelectPattern -> Text -> Maybe ChannelSelectMatch+applySelectPattern (CSP ty pat) chanName = do+ let applyType Infix | pat `T.isInfixOf` chanName =+ case T.breakOn pat chanName of+ (pre, post) -> return (pre, pat, T.drop (T.length pat) post)++ applyType Prefix | pat `T.isPrefixOf` chanName = do+ let (b, a) = T.splitAt (T.length pat) chanName+ return ("", b, a)++ applyType UsersOnly | pat `T.isPrefixOf` chanName = do+ let (b, a) = T.splitAt (T.length pat) chanName+ return ("", b, a)++ applyType ChannelsOnly | pat `T.isPrefixOf` chanName = do+ let (b, a) = T.splitAt (T.length pat) chanName+ return ("", b, a)++ applyType Suffix | pat `T.isSuffixOf` chanName = do+ let (b, a) = T.splitAt (T.length chanName - T.length pat) chanName+ return (b, a, "")++ applyType Equal | pat == chanName =+ return ("", chanName, "")++ applyType _ = Nothing++ (pre, m, post) <- applyType ty+ return $ ChannelSelectMatch pre m post chanName++parseChannelSelectPattern :: Text -> Maybe ChannelSelectPattern+parseChannelSelectPattern pat = do+ let only = if | userSigil `T.isPrefixOf` pat -> Just $ CSP UsersOnly $ T.tail pat+ | normalChannelSigil `T.isPrefixOf` pat -> Just $ CSP ChannelsOnly $ T.tail pat+ | otherwise -> Nothing++ (pat1, pfx) <- case "^" `T.isPrefixOf` pat of+ True -> return (T.tail pat, Just Prefix)+ False -> return (pat, Nothing)++ (pat2, sfx) <- case "$" `T.isSuffixOf` pat1 of+ True -> return (T.init pat1, Just Suffix)+ False -> return (pat1, Nothing)++ only <|> case (pfx, sfx) of+ (Nothing, Nothing) -> return $ CSP Infix pat2+ (Just Prefix, Nothing) -> return $ CSP Prefix pat2+ (Nothing, Just Suffix) -> return $ CSP Suffix pat2+ (Just Prefix, Just Suffix) -> return $ CSP Equal pat2+ tys -> error $ "BUG: invalid channel select case: " <> show tys++-- Update the channel selection mode match cursor. The argument function+-- determines how the new cursor position is computed from the old+-- one. The new cursor position is automatically wrapped around to the+-- beginning or end of the channel selection match list, so cursor+-- transformations do not have to do index validation. If the current+-- match (e.g. the sentinel "") is not found in the match list, this+-- sets the cursor position to the first match, if any.+updateSelectedMatch :: (Int -> Int) -> MH ()+updateSelectedMatch nextIndex = do+ chanMatches <- use (csChannelSelectState.channelMatches)+ usernameMatches <- use (csChannelSelectState.userMatches)++ csChannelSelectState.selectedMatch %= \oldMatch ->+ -- Make the list of all matches, in display order.+ let allMatches = concat [ (ChannelMatch . matchFull) <$> chanMatches+ , (UserMatch . matchFull) <$> usernameMatches+ ]+ defaultMatch = if null allMatches+ then Nothing+ else Just $ allMatches !! 0+ in case oldMatch of+ Nothing -> defaultMatch+ Just oldMatch' -> case findIndex (== oldMatch') allMatches of+ Nothing -> defaultMatch+ Just i ->+ let newIndex = if tmpIndex < 0+ then length allMatches - 1+ else if tmpIndex >= length allMatches+ then 0+ else tmpIndex+ tmpIndex = nextIndex i+ in Just $ allMatches !! newIndex
+ src/State/Channels.hs view
@@ -0,0 +1,873 @@+{-# LANGUAGE LambdaCase #-}+{-# LANGUAGE MultiWayIf #-}+module State.Channels+ ( updateViewed+ , updateViewedChan+ , refreshChannel+ , refreshChannelsAndUsers+ , setFocus+ , setFocusWith+ , refreshChannelById+ , applyPreferenceChange+ , leaveChannel+ , leaveChannelIfPossible+ , leaveCurrentChannel+ , getNextUnreadChannel+ , nextUnreadChannel+ , prevChannel+ , nextChannel+ , recentChannel+ , createGroupChannel+ , showGroupChannelPref+ , channelHistoryForward+ , channelHistoryBackward+ , handleNewChannel+ , createOrdinaryChannel+ , handleChannelInvite+ , addUserToCurrentChannel+ , removeUserFromCurrentChannel+ , removeChannelFromState+ , isRecentChannel+ , isCurrentChannel+ , deleteCurrentChannel+ , startLeaveCurrentChannel+ , joinChannel+ , joinChannelByName+ , startJoinChannel+ , changeChannel+ , setChannelTopic+ , beginCurrentChannelDeleteConfirm+ )+where++import Prelude ()+import Prelude.MH++import Brick.Main ( viewportScroll, vScrollToBeginning )+import Brick.Widgets.Edit ( applyEdit, getEditContents, editContentsL )+import Brick.Widgets.List ( list )+import Control.Concurrent.Async ( runConcurrently, Concurrently(..) )+import Control.Exception ( SomeException, try )+import Data.Char ( isAlphaNum )+import qualified Data.HashMap.Strict as HM+import Data.Function ( on )+import Data.Maybe ( fromJust )+import qualified Data.Sequence as Seq+import qualified Data.Text as T+import qualified Data.Vector as V+import Data.Text.Zipper ( textZipper, clearZipper, insertMany, gotoEOL )+import Lens.Micro.Platform++import qualified Network.Mattermost.Endpoints as MM+import Network.Mattermost.Lenses+import Network.Mattermost.Types++import InputHistory+import State.Common+import State.Users+import State.Flagging+import State.Setup.Threads ( updateUserStatuses )+import Types+import Types.Common+import Zipper ( Zipper )+import qualified Zipper as Z+++updateViewed :: MH ()+updateViewed = do+ csCurrentChannel.ccInfo.cdMentionCount .= 0+ updateViewedChan =<< use csCurrentChannelId++-- | When a new channel has been selected for viewing, this will+-- notify the server of the change, and also update the local channel+-- state to set the last-viewed time for the previous channel and+-- update the viewed time to now for the newly selected channel.+updateViewedChan :: ChannelId -> MH ()+updateViewedChan cId = use csConnectionStatus >>= \case+ Connected -> do+ -- Only do this if we're connected to avoid triggering noisy+ -- exceptions.+ pId <- use csRecentChannel+ doAsyncChannelMM Preempt cId+ (\s _ c -> MM.mmViewChannel UserMe c pId s)+ (\c () -> setLastViewedFor pId c)+ Disconnected ->+ -- Cannot update server; make no local updates to avoid getting+ -- out-of-sync with the server. Assumes that this is a temporary+ -- break in connectivity and that after the connection is+ -- restored, the user's normal activities will update state as+ -- appropriate. If connectivity is permanently lost, managing+ -- this state is irrelevant.+ return ()++-- | Called on async completion when the currently viewed channel has+-- been updated (i.e., just switched to this channel) to update local+-- state.+setLastViewedFor :: Maybe ChannelId -> ChannelId -> MH ()+setLastViewedFor prevId cId = do+ chan <- use (csChannels.to (findChannelById cId))+ -- Update new channel's viewed time, creating the channel if needed+ case chan of+ Nothing ->+ -- It's possible for us to get spurious WMChannelViewed+ -- events from the server, e.g. for channels that have been+ -- deleted. So here we ignore the request since it's hard to+ -- detect it before this point.+ return ()+ Just _ ->+ -- The server has been sent a viewed POST update, but there is+ -- no local information on what timestamp the server actually+ -- recorded. There are a couple of options for setting the+ -- local value of the viewed time:+ --+ -- 1. Attempting to locally construct a value, which would+ -- involve scanning all (User) messages in the channel+ -- to find the maximum of the created date, the modified+ -- date, or the deleted date, and assuming that maximum+ -- mostly matched the server's viewed time.+ --+ -- 2. Issuing a channel metadata request to get the server's+ -- new concept of the viewed time.+ --+ -- 3. Having the "chan/viewed" POST that was just issued+ -- return a value from the server. See+ -- https://github.com/mattermost/platform/issues/6803.+ --+ -- Method 3 would be the best and most lightweight. Until that+ -- is available, Method 2 will be used. The downside to Method+ -- 2 is additional client-server messaging, and a delay in+ -- 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 (\ 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 ()+ Just p -> csChannels %= (channelByIdL p %~ (clearNewMessageIndicator . clearEditedThreshold))++-- | Refresh information about all channels and users. This is usually+-- triggered when a reconnect event for the WebSocket to the server+-- 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 <- getSession+ myTId <- gets myTeamId+ doAsyncWith Preempt $ do+ (chans, datas) <- runConcurrently $ (,)+ <$> Concurrently (MM.mmGetChannelsForUser UserMe myTId session)+ <*> Concurrently (MM.mmGetChannelMembersForUser UserMe myTId session)++ let dataMap = HM.fromList $ toList $ (\d -> (channelMemberChannelId d, d)) <$> datas+ mkPair chan = (chan, fromJust $ HM.lookup (channelId chan) dataMap)+ chansWithData = mkPair <$> chans++ asyncFetchAllUsers page accum final = do+ doAsyncWith Preempt $ do+ let pageSize = 200+ userQuery = MM.defaultUserQuery+ { MM.userQueryPage = Just page+ , MM.userQueryPerPage = Just pageSize+ , MM.userQueryInTeam = Just myTId+ }+ batch <- MM.mmGetUsers userQuery session++ return $ case length batch < pageSize of+ True -> do+ let users = accum <> batch+ forM_ users $ \u -> do+ when (not $ userDeleted u) $ do+ result <- gets (userById (getId u))+ when (isNothing result) $ handleNewUserDirect u+ setUserIdSet (userId <$> users)+ final+ False ->+ asyncFetchAllUsers (page + 1) (accum <> batch) final++ return $ do+ asyncFetchAllUsers 0 mempty $ do+ forM_ chansWithData $ uncurry refreshChannel+ lock <- use (csResources.crUserStatusLock)+ setVar <- use (csResources.crUserIdSet)+ doAsyncWith Preempt $ updateUserStatuses setVar lock session++-- | 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 :: Channel -> ChannelMember -> MH ()+refreshChannel chan member = do+ let cId = getId chan+ myTId <- gets myTeamId+ let ourTeam = channelTeamId chan == Nothing ||+ Just myTId == channelTeamId chan++ -- If this is a group channel that the user has chosen to hide or if+ -- the channel is not a channel for the current session's team, ignore+ -- the refresh request.+ isHidden <- channelHiddenPreference cId+ case isHidden || not ourTeam of+ True -> return ()+ False -> do+ -- If this channel is unknown, register it first.+ mChan <- preuse (csChannel(cId))+ when (isNothing mChan) $+ handleNewChannel False chan member++ updateChannelInfo cId chan member++channelHiddenPreference :: ChannelId -> MH Bool+channelHiddenPreference cId = do+ prefs <- use (csResources.crUserPreferences.userPrefGroupChannelPrefs)+ let matching = filter (\p -> fst p == cId) (HM.toList prefs)+ return $ any (not . snd) matching++handleNewChannel :: Bool -> Channel -> ChannelMember -> MH ()+handleNewChannel = handleNewChannel_ True++handleNewChannel_ :: Bool+ -- ^ Whether to permit this call to recursively+ -- schedule itself for later if it can't locate+ -- a DM channel user record. This is to prevent+ -- uncontrolled recursion.+ -> Bool+ -- ^ Whether to switch to the new channel once it has+ -- been installed.+ -> Channel+ -- ^ The channel to install.+ -> ChannelMember+ -> MH ()+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+ Just _ -> when switch $ setFocus (getId nc)+ Nothing -> do+ -- Create a new ClientChannel structure+ cChannel <- (ccInfo %~ channelInfoFromChannelWithData nc member) <$>+ makeClientChannel nc++ st <- use id++ -- Add it to the message map, and to the name map so we+ -- can look it up by name. The name we use for the channel+ -- depends on its type:+ let chType = nc^.channelTypeL++ -- Get the channel name. If we couldn't, that means we have+ -- async work to do before we can register this channel (in+ -- which case abort because we got rescheduled).+ mName <- case chType of+ Direct -> case userIdForDMChannel (myUserId st) (sanitizeUserText $ channelName nc) of+ -- If this is a direct channel but we can't extract+ -- a user ID from the name, then it failed to+ -- parse. We need to assign a channel name in our+ -- channel map, and the best we can do to preserve+ -- uniqueness is to use the channel name string.+ -- This is undesirable but direct channels never get+ -- rendered directly; they only get used by first+ -- looking up usernames. So this name should never+ -- appear anywhere, but at least we can go ahead and+ -- register the channel and handle events for it.+ -- That isn't very useful but it's probably better+ -- than ignoring this entirely.+ Nothing -> return $ Just $ sanitizeUserText $ channelName nc+ Just otherUserId ->+ case usernameForUserId otherUserId st of+ -- If we found a user ID in the channel+ -- name string but don't have that user's+ -- metadata, postpone adding this channel+ -- until we have fetched the metadata. This+ -- can happen when we have a channel record+ -- for a user that is no longer in the+ -- current team. To avoid recursion due to a+ -- problem, ensure that the rescheduled new+ -- channel handler is not permitted to try+ -- this again.+ --+ -- If we're already in a recursive attempt+ -- to register this channel and still+ -- couldn't find a username, just bail and+ -- use the synthetic name (this has the same+ -- problems as above).+ Nothing -> do+ case permitPostpone of+ False -> return $ Just $ sanitizeUserText $ channelName nc+ True -> do+ handleNewUsers $ Seq.singleton otherUserId+ doAsyncWith Normal $+ return $ handleNewChannel_ False switch nc member+ return Nothing+ Just ncUsername ->+ return $ Just $ ncUsername+ _ -> return $ Just $ preferredChannelName nc++ case mName of+ Nothing -> return ()+ Just name -> do+ addChannelName chType (getId nc) name+ csChannels %= addChannel (getId nc) cChannel+ refreshChannelZipper++ -- Finally, set our focus to the newly created+ -- channel if the caller requested a change of+ -- channel. Also consider the last join request+ -- state field in case this is an asynchronous+ -- channel addition triggered by a /join.+ lastReq <- use csLastJoinRequest+ wasLast <- case lastReq of+ Just cId | cId == getId nc -> do+ csLastJoinRequest .= Nothing+ return True+ _ -> return False++ when (switch || wasLast) $ setFocus (getId nc)++-- | Update the indicated Channel entry with the new data retrieved from+-- the Mattermost server. Also update the channel name if it changed.+updateChannelInfo :: ChannelId -> Channel -> ChannelMember -> MH ()+updateChannelInfo cid new member = do+ mOldChannel <- preuse $ csChannel(cid)+ case mOldChannel of+ Nothing -> return ()+ Just old ->+ let oldName = old^.ccInfo.cdName+ newName = preferredChannelName new+ in if oldName == newName+ then return ()+ else do+ removeChannelName oldName+ addChannelName (channelType new) cid newName++ csChannel(cid).ccInfo %= channelInfoFromChannelWithData new member++setFocus :: ChannelId -> MH ()+setFocus cId = setFocusWith (Z.findRight (== cId))++setFocusWith :: (Zipper ChannelId -> Zipper ChannelId) -> MH ()+setFocusWith f = do+ oldZipper <- use csFocus+ let newZipper = f oldZipper+ newFocus = Z.focus newZipper+ oldFocus = Z.focus oldZipper++ -- If we aren't changing anything, skip all the book-keeping because+ -- we'll end up clobbering things like csRecentChannel.+ when (newFocus /= oldFocus) $ do+ preChangeChannelCommon+ csFocus .= newZipper+ updateViewed+ postChangeChannelCommon++postChangeChannelCommon :: MH ()+postChangeChannelCommon = do+ resetHistoryPosition+ resetEditorState+ updateChannelListScroll+ loadLastEdit+ resetCurrentEdit++resetCurrentEdit :: MH ()+resetCurrentEdit = do+ cId <- use csCurrentChannelId+ csEditState.cedLastChannelInput.at cId .= Nothing++loadLastEdit :: MH ()+loadLastEdit = do+ cId <- use csCurrentChannelId+ lastInput <- use (csEditState.cedLastChannelInput.at cId)+ case lastInput of+ Nothing -> return ()+ Just (lastEdit, lastEditMode) -> do+ csEditState.cedEditor %= (applyEdit $ insertMany (lastEdit) . clearZipper)+ csEditState.cedEditMode .= lastEditMode++resetHistoryPosition :: MH ()+resetHistoryPosition = do+ cId <- use csCurrentChannelId+ csEditState.cedInputHistoryPosition.at cId .= Just Nothing++updateChannelListScroll :: MH ()+updateChannelListScroll = do+ mh $ vScrollToBeginning (viewportScroll ChannelList)++preChangeChannelCommon :: MH ()+preChangeChannelCommon = do+ cId <- use csCurrentChannelId+ csRecentChannel .= Just cId+ saveCurrentEdit++resetEditorState :: MH ()+resetEditorState = do+ csEditState.cedEditMode .= NewPost+ clearEditor++clearEditor :: MH ()+clearEditor = csEditState.cedEditor %= applyEdit clearZipper++saveCurrentEdit :: MH ()+saveCurrentEdit = do+ cId <- use csCurrentChannelId+ cmdLine <- use (csEditState.cedEditor)+ mode <- use (csEditState.cedEditMode)+ csEditState.cedLastChannelInput.at cId .=+ Just (T.intercalate "\n" $ getEditContents $ cmdLine, mode)++hideGroupChannelPref :: ChannelId -> UserId -> Preference+hideGroupChannelPref cId uId =+ Preference { preferenceCategory = PreferenceCategoryGroupChannelShow+ , preferenceValue = PreferenceValue "false"+ , preferenceName = PreferenceName $ idString cId+ , preferenceUserId = uId+ }++showGroupChannelPref :: ChannelId -> UserId -> Preference+showGroupChannelPref cId uId =+ Preference { preferenceCategory = PreferenceCategoryGroupChannelShow+ , preferenceValue = PreferenceValue "true"+ , preferenceName = PreferenceName $ idString cId+ , preferenceUserId = uId+ }++applyPreferenceChange :: Preference -> MH ()+applyPreferenceChange pref = do+ -- always update our user preferences accordingly+ csResources.crUserPreferences %= setUserPreferences (Seq.singleton pref)+ if+ | Just f <- preferenceToFlaggedPost pref -> do+ updateMessageFlag (flaggedPostId f) (flaggedPostStatus f)+ | Just g <- preferenceToGroupChannelPreference pref -> do+ let cId = groupChannelId g+ mChan <- preuse $ csChannel cId++ case (mChan, groupChannelShow g) of+ (Just _, False) ->+ -- If it has been set to hidden and we are showing it,+ -- remove it from the state.+ removeChannelFromState cId+ (Nothing, True) ->+ -- If it has been set to showing and we are not showing+ -- it, ask for a load/refresh.+ refreshChannelById cId+ _ -> return ()+ | otherwise -> return ()++refreshChannelById :: ChannelId -> MH ()+refreshChannelById cId = do+ session <- getSession+ doAsyncWith Preempt $ do+ cwd <- MM.mmGetChannel cId session+ member <- MM.mmGetChannelMember cId UserMe session+ return $ refreshChannel cwd member++removeChannelFromState :: ChannelId -> MH ()+removeChannelFromState cId = do+ withChannel cId $ \ chan -> do+ let cName = chan^.ccInfo.cdName+ chType = chan^.ccInfo.cdType+ when (chType /= Direct) $ do+ origFocus <- use csCurrentChannelId+ when (origFocus == cId) nextChannel+ csEditState.cedInputHistoryPosition .at cId .= Nothing+ csEditState.cedLastChannelInput .at cId .= Nothing+ -- Update input history+ csEditState.cedInputHistory %= removeChannelHistory cId+ -- Remove channel name mappings+ removeChannelName cName+ -- Update msgMap+ csChannels %= filteredChannels ((/=) cId . fst)+ -- Remove from focus zipper+ csFocus %= Z.filterZipper (/= cId)++nextChannel :: MH ()+nextChannel = do+ st <- use id+ setFocusWith (getNextNonDMChannel st Z.right)++prevChannel :: MH ()+prevChannel = do+ st <- use id+ setFocusWith (getNextNonDMChannel st Z.left)++recentChannel :: MH ()+recentChannel = do+ recent <- use csRecentChannel+ case recent of+ Nothing -> return ()+ Just cId -> setFocus cId++nextUnreadChannel :: MH ()+nextUnreadChannel = do+ st <- use id+ setFocusWith (getNextUnreadChannel st)++leaveChannel :: ChannelId -> MH ()+leaveChannel cId = leaveChannelIfPossible cId False++leaveChannelIfPossible :: ChannelId -> Bool -> MH ()+leaveChannelIfPossible cId delete = do+ st <- use id+ me <- gets myUser+ let isMe u = u^.userIdL == me^.userIdL++ case st ^? csChannel(cId).ccInfo of+ Nothing -> return ()+ Just cInfo -> case canLeaveChannel cInfo of+ False -> return ()+ True ->+ -- The server will reject an attempt to leave a private+ -- channel if we're the only member. To check this, we+ -- just ask for the first two members of the channel.+ -- If there is only one, it must be us: hence the "all+ -- isMe" check below. If there are two members, it+ -- doesn't matter who they are, because we just know+ -- that we aren't the only remaining member, so we can't+ -- delete the channel.+ doAsyncChannelMM Preempt cId+ (\s _ _ ->+ let query = MM.defaultUserQuery+ { MM.userQueryPage = Just 0+ , MM.userQueryPerPage = Just 2+ , MM.userQueryInChannel = Just cId+ }+ in toList <$> MM.mmGetUsers query s)+ (\_ members -> do+ -- If the channel is private:+ -- * leave it if we aren't the last member.+ -- * delete it if we are.+ --+ -- Otherwise:+ -- * leave (or delete) the channel as specified+ -- by the delete argument.+ let func = case cInfo^.cdType of+ Private -> case all isMe members of+ True -> (\ s _ c -> MM.mmDeleteChannel c s)+ False -> (\ s _ c -> MM.mmRemoveUserFromChannel c UserMe s)+ Group ->+ \s _ _ ->+ let pref = hideGroupChannelPref cId (me^.userIdL)+ in MM.mmSaveUsersPreferences UserMe (Seq.singleton pref) s+ _ -> if delete+ then (\ s _ c -> MM.mmDeleteChannel c s)+ else (\ s _ c -> MM.mmRemoveUserFromChannel c UserMe s)++ doAsyncChannelMM Preempt cId func endAsyncNOP+ )++getNextUnreadChannel :: ChatState+ -> (Zipper ChannelId -> Zipper ChannelId)+getNextUnreadChannel st =+ -- The next channel with unread messages must also be a channel+ -- other than the current one, since the zipper may be on a channel+ -- that has unread messages and will stay that way until we leave+ -- it- so we need to skip that channel when doing the zipper search+ -- for the next candidate channel.+ Z.findRight (\cId -> hasUnread st cId && (cId /= st^.csCurrentChannelId))++getNextNonDMChannel :: ChatState+ -> (Zipper ChannelId -> Zipper ChannelId)+ -> (Zipper ChannelId -> Zipper ChannelId)+getNextNonDMChannel st shift z =+ if fType z == Direct+ then z+ else go (shift z)+ where go z'+ | fType z' /= Direct = z'+ | otherwise = go (shift z')+ fType onz = st^.(csChannels.to+ (findChannelById (Z.focus onz))) ^?! _Just.ccInfo.cdType++leaveCurrentChannel :: MH ()+leaveCurrentChannel = use csCurrentChannelId >>= leaveChannel++createGroupChannel :: Text -> MH ()+createGroupChannel usernameList = do+ st <- use id+ me <- gets myUser++ let usernames = T.words usernameList+ findUserIds [] = return []+ findUserIds (n:ns) = do+ case userByUsername n st of+ Nothing -> do+ mhError $ NoSuchUser n+ return []+ Just u -> (u^.uiId:) <$> findUserIds ns++ results <- findUserIds usernames++ -- If we found all of the users mentioned, then create the group+ -- channel.+ when (length results == length usernames) $ do+ session <- getSession+ doAsyncWith Preempt $ do+ 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.+ MM.mmSaveUsersPreferences UserMe (Seq.singleton pref) session+ cwd <- MM.mmGetChannel (channelId chan) session+ member <- MM.mmGetChannelMember (channelId chan) UserMe session+ return $ do+ applyPreferenceChange pref+ handleNewChannel True cwd member++channelHistoryForward :: MH ()+channelHistoryForward = do+ cId <- use csCurrentChannelId+ inputHistoryPos <- use (csEditState.cedInputHistoryPosition.at cId)+ inputHistory <- use (csEditState.cedInputHistory)+ case inputHistoryPos of+ Just (Just i)+ | i == 0 -> do+ -- Transition out of history navigation+ csEditState.cedInputHistoryPosition.at cId .= Just Nothing+ loadLastEdit+ | otherwise -> do+ let Just entry = getHistoryEntry cId newI inputHistory+ newI = i - 1+ eLines = T.lines entry+ mv = if length eLines == 1 then gotoEOL else id+ csEditState.cedEditor.editContentsL .= (mv $ textZipper eLines Nothing)+ csEditState.cedInputHistoryPosition.at cId .= (Just $ Just newI)+ _ -> return ()++channelHistoryBackward :: MH ()+channelHistoryBackward = do+ cId <- use csCurrentChannelId+ inputHistoryPos <- use (csEditState.cedInputHistoryPosition.at cId)+ inputHistory <- use (csEditState.cedInputHistory)+ case inputHistoryPos of+ Just (Just i) ->+ let newI = i + 1+ in case getHistoryEntry cId newI inputHistory of+ Nothing -> return ()+ Just entry -> do+ let eLines = T.lines entry+ mv = if length eLines == 1 then gotoEOL else id+ csEditState.cedEditor.editContentsL .= (mv $ textZipper eLines Nothing)+ csEditState.cedInputHistoryPosition.at cId .= (Just $ Just newI)+ _ ->+ let newI = 0+ in case getHistoryEntry cId newI inputHistory of+ Nothing -> return ()+ Just entry ->+ let eLines = T.lines entry+ mv = if length eLines == 1 then gotoEOL else id+ in do+ saveCurrentEdit+ csEditState.cedEditor.editContentsL .= (mv $ textZipper eLines Nothing)+ csEditState.cedInputHistoryPosition.at cId .= (Just $ Just newI)++createOrdinaryChannel :: Text -> MH ()+createOrdinaryChannel name = do+ session <- getSession+ myTId <- gets myTeamId+ doAsyncWith Preempt $ do+ -- create a new chat channel+ let slug = T.map (\ c -> if isAlphaNum c then c else '-') (T.toLower name)+ minChannel = MinChannel+ { minChannelName = slug+ , minChannelDisplayName = name+ , minChannelPurpose = Nothing+ , minChannelHeader = Nothing+ , minChannelType = Ordinary+ , minChannelTeamId = myTId+ }+ tryMM (do c <- MM.mmCreateChannel minChannel session+ chan <- MM.mmGetChannel (getId c) session+ member <- MM.mmGetChannelMember (getId c) UserMe session+ return (chan, member)+ )+ (return . uncurry (handleNewChannel True))++-- | When another user adds us to a channel, we need to fetch the+-- channel info for that channel.+handleChannelInvite :: ChannelId -> MH ()+handleChannelInvite cId = do+ session <- getSession+ doAsyncWith Normal $ do+ member <- MM.mmGetChannelMember cId UserMe session+ tryMM (MM.mmGetChannel cId session)+ (\cwd -> return $ handleNewChannel False cwd member)++addUserToCurrentChannel :: Text -> MH ()+addUserToCurrentChannel uname = do+ -- First: is this a valid username?+ result <- gets (userByUsername uname)+ case result of+ Just u -> do+ cId <- use csCurrentChannelId+ session <- getSession+ let channelMember = MinChannelMember (u^.uiId) cId+ doAsyncWith Normal $ do+ tryMM (void $ MM.mmAddUser cId channelMember session)+ (const $ return (return ()))+ _ -> do+ mhError $ NoSuchUser uname++removeUserFromCurrentChannel :: Text -> MH ()+removeUserFromCurrentChannel uname = do+ -- First: is this a valid username?+ result <- gets (userByUsername uname)+ case result of+ Just u -> do+ cId <- use csCurrentChannelId+ session <- getSession+ doAsyncWith Normal $ do+ tryMM (void $ MM.mmRemoveUserFromChannel cId (UserById $ u^.uiId) session)+ (const $ return (return ()))+ _ -> do+ mhError $ NoSuchUser uname++startLeaveCurrentChannel :: MH ()+startLeaveCurrentChannel = do+ cInfo <- use (csCurrentChannel.ccInfo)+ case canLeaveChannel cInfo of+ True -> setMode LeaveChannelConfirm+ False -> mhError $ GenericError "The /leave command cannot be used with this channel."++deleteCurrentChannel :: MH ()+deleteCurrentChannel = do+ setMode Main+ cId <- use csCurrentChannelId+ leaveChannelIfPossible cId True++isCurrentChannel :: ChatState -> ChannelId -> Bool+isCurrentChannel st cId = st^.csCurrentChannelId == cId++isRecentChannel :: ChatState -> ChannelId -> Bool+isRecentChannel st cId = st^.csRecentChannel == Just cId++joinChannelByName :: Text -> MH ()+joinChannelByName rawName = do+ session <- getSession+ tId <- gets myTeamId+ doAsyncWith Preempt $ do+ result <- try $ MM.mmGetChannelByName tId (trimChannelSigil rawName) session+ return $ case result of+ Left (_::SomeException) -> mhError $ NoSuchChannel rawName+ Right chan -> joinChannel $ getId chan++startJoinChannel :: MH ()+startJoinChannel = do+ session <- getSession+ myTId <- gets myTeamId+ 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 <- MM.mmGetPublicChannels myTId (Just start) (Just fetchCount) session+ let chans = acc <> newChans+ if length newChans < fetchCount+ then return chans+ else loop chans (start+1)+ chans <- Seq.filter (\ c -> not (channelId c `elem` myChannels)) <$> loop mempty 0+ let sortedChans = V.fromList $ toList $ Seq.sortBy (compare `on` channelName) chans+ return $ do+ csJoinChannelList .= (Just $ list JoinChannelList sortedChans 2)++ setMode JoinChannel+ csJoinChannelList .= Nothing++-- | If the user is not a member of the specified channel, submit a+-- request to join it. Otherwise switch to the channel.+joinChannel :: ChannelId -> MH ()+joinChannel chanId = do+ setMode Main+ mChan <- preuse (csChannel(chanId))+ case mChan of+ Just _ -> setFocus chanId+ Nothing -> do+ myId <- gets myUserId+ let member = MinChannelMember myId chanId+ csLastJoinRequest .= Just chanId+ doAsyncChannelMM Preempt chanId (\ s _ c -> MM.mmAddUser c member s) endAsyncNOP++attemptCreateDMChannel :: Text -> MH ()+attemptCreateDMChannel name = do+ mCid <- gets (channelIdByUsername name)+ me <- gets myUser+ displayNick <- use (to useNickname)+ uList <- use (to sortedUserList)+ let myName = if displayNick && not (T.null $ sanitizeUserText $ userNickname me)+ then sanitizeUserText $ userNickname me+ else me^.userUsernameL+ when (name /= myName) $ do+ let uName = if displayNick+ then+ maybe name (view uiName)+ $ findUserByNickname uList name+ else name+ mUid <- gets (userIdForUsername uName)+ if isJust mUid && isNothing mCid+ then do+ -- We have a user of that name but no channel. Time to make one!+ let Just uId = mUid+ myId <- gets myUserId+ session <- getSession+ doAsyncWith Normal $ do+ -- create a new channel+ 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+ mhError $ NoSuchUser name++-- | This switches to the named channel or creates it if it is a missing+-- but valid user channel.+changeChannel :: Text -> MH ()+changeChannel name = do+ result <- gets (channelIdByName name)+ user <- gets (userByUsername name)+ let err = mhError $ AmbiguousName name++ case result of+ (Nothing, Nothing)+ -- We know about the user but there isn't already a DM+ -- channel, so create one.+ | Just _ <- user -> attemptCreateDMChannel name+ -- There were no matches of any kind.+ | otherwise -> mhError $ NoSuchChannel name+ (Just cId, Nothing)+ -- We matched a channel and there was an explicit sigil, so we+ -- don't care about the username match.+ | normalChannelSigil `T.isPrefixOf` name -> setFocus cId+ -- We matched both a channel and a user, even though there is+ -- no DM channel.+ | Just _ <- user -> err+ -- We matched a channel only.+ | otherwise -> setFocus cId+ (Nothing, Just cId) ->+ -- We matched a user only and there is already a DM channel.+ setFocus cId+ (Just _, Just _) ->+ -- We matched both a channel and a user.+ err++setChannelTopic :: Text -> MH ()+setChannelTopic msg = do+ cId <- use csCurrentChannelId+ let patch = defaultChannelPatch { channelPatchHeader = Just msg }+ doAsyncChannelMM Preempt cId+ (\s _ _ -> MM.mmPatchChannel cId patch s)+ (\_ _ -> return ())++beginCurrentChannelDeleteConfirm :: MH ()+beginCurrentChannelDeleteConfirm = do+ cId <- use csCurrentChannelId+ withChannel cId $ \chan -> do+ let chType = chan^.ccInfo.cdType+ if chType /= Direct+ then setMode DeleteChannelConfirm+ else mhError $ GenericError "Direct message channels cannot be deleted."
src/State/Common.hs view
@@ -1,167 +1,54 @@-module State.Common where+module State.Common+ (+ -- * System interface+ openURL+ , runLoggedCommand + -- * Posts+ , messagesFromPosts++ -- * Utilities+ , postInfoMessage+ , postErrorMessageIO+ , postErrorMessage'+ , addEmoteFormatting+ , removeEmoteFormatting++ , module State.Async+ )+where+ import Prelude () import Prelude.MH +import Control.Concurrent ( MVar, putMVar, forkIO )+import Control.Concurrent.Async ( concurrently ) import qualified Control.Concurrent.STM as STM-import Control.Exception ( try )-import qualified Data.Foldable as F+import Control.Exception ( SomeException, try )+import qualified Data.ByteString as BS import qualified Data.HashMap.Strict as HM-import qualified Data.Map.Strict as Map import qualified Data.Sequence as Seq import qualified Data.Set as Set import qualified Data.Text as T-import Lens.Micro.Platform ( (%=), (%~), (.~), traversed )-import System.Hclip ( setClipboard, ClipboardException(..) )+import Lens.Micro.Platform ( (.=), (%=), (%~), (.~) )+import System.Directory ( createDirectoryIfMissing )+import System.Environment.XDG.BaseDir ( getUserCacheDir )+import System.Exit ( ExitCode(..) )+import System.FilePath+import System.IO ( hGetContents, hFlush, hPutStrLn )+import System.Process ( proc, std_in, std_out, std_err, StdStream(..)+ , createProcess, waitForProcess ) import Network.Mattermost.Endpoints import Network.Mattermost.Lenses import Network.Mattermost.Types +import FilePaths ( xdgName )+import State.Async import Types+import Types.Common --- * Mattermost API---- | Try to run a computation, posting an informative error--- message if it fails with a 'MattermostServerError'.-tryMM :: IO a- -- ^ The action to try (usually a MM API call)- -> (a -> IO (MH ()))- -- ^ What to do on success- -> IO (MH ())-tryMM act onSuccess = do- result <- liftIO $ try act- case result of- Left e -> return $ mhError $ ServerError e- Right value -> liftIO $ onSuccess value---- * Background Computation---- $background_computation------ The main context for Matterhorn is the EventM context provided by--- the 'Brick' library. This context is normally waiting for user--- input (or terminal resizing, etc.) which gets turned into an--- MHEvent and the 'onEvent' event handler is called to process that--- event, after which the display is redrawn as necessary and brick--- awaits the next input.------ However, it is often convenient to communicate with the Mattermost--- server in the background, so that large numbers of--- synchronously-blocking events (e.g. on startup) or refreshes can--- occur whenever needed and without negatively impacting the UI--- updates or responsiveness. This is handled by a 'forkIO' context--- that waits on an STM channel for work to do, performs the work, and--- then sends brick an MHEvent containing the completion or failure--- information for that work.------ The /doAsyncWith/ family of functions here facilitates that--- asynchronous functionality. This is typically used in the--- following fashion:------ > doSomething :: MH ()--- > doSomething = do--- > got <- something--- > doAsyncWith Normal $ do--- > r <- mmFetchR ....--- > return $ do--- > csSomething.here %= processed r------ The second argument is an IO monad operation (because 'forkIO' runs--- in the IO Monad context), but it returns an MH monad operation.--- The IO monad has access to the closure of 'doSomething' (e.g. the--- 'got' value), but it should be aware that the state of the MH monad--- may have been changed by the time the IO monad runs in the--- background, so the closure is a snapshot of information at the time--- the 'doAsyncWith' was called.------ Similarly, the returned MH monad operation is *not* run in the--- context of the 'forkIO' background, but it is instead passed via an--- MHEvent back to the main brick thread, where it is executed in an--- EventM handler's MH monad context. This operation therefore has--- access to the combined closure of the pre- 'doAsyncWith' code and--- the closure of the IO operation. It is important that the final MH--- monad operation should *re-obtain* state information from the MH--- monad instead of using or setting the state obtained prior to the--- 'doAsyncWith' call.---- | Priority setting for asynchronous work items. Preempt means that--- the queued item will be the next work item begun (i.e. it goes to the--- front of the queue); normal means it will go last in the queue.-data AsyncPriority = Preempt | Normal---- | Run a computation in the background, ignoring any results from it.-doAsync :: AsyncPriority -> IO () -> MH ()-doAsync prio act = doAsyncWith prio (act >> return (return ()))---- | Run a computation in the background, returning a computation to be--- called on the 'ChatState' value.-doAsyncWith :: AsyncPriority -> IO (MH ()) -> MH ()-doAsyncWith prio act = do- let putChan = case prio of- Preempt -> STM.unGetTChan- Normal -> STM.writeTChan- queue <- use (csResources.crRequestQueue)- liftIO $ STM.atomically $ putChan queue act--doAsyncIO :: AsyncPriority -> ChatState -> IO () -> IO ()-doAsyncIO prio st act =- doAsyncWithIO prio st (act >> return (return ()))---- | Run a computation in the background, returning a computation to be--- called on the 'ChatState' value.-doAsyncWithIO :: AsyncPriority -> ChatState -> IO (MH ()) -> IO ()-doAsyncWithIO prio st act = do- let putChan = case prio of- Preempt -> STM.unGetTChan- Normal -> STM.writeTChan- let queue = st^.csResources.crRequestQueue- STM.atomically $ putChan queue act---- | Performs an asynchronous IO operation. On completion, the final--- argument a completion function is executed in an MH () context in the--- main (brick) thread.-doAsyncMM :: AsyncPriority- -- ^ the priority for this async operation- -> (Session -> TeamId -> IO a)- -- ^ the async MM channel-based IO operation- -> (a -> MH ())- -- ^ function to process the results in brick event handling- -- context- -> MH ()-doAsyncMM prio mmOp eventHandler = do- session <- getSession- tId <- gets myTeamId- doAsyncWith prio $ do- r <- mmOp session tId- return $ eventHandler r---- | Helper type for a function to perform an asynchronous MM operation--- on a channel and then invoke an MH completion event.-type DoAsyncChannelMM a =- AsyncPriority- -- ^ the priority for this async operation- -> ChannelId- -- ^ The channel- -> (Session -> TeamId -> ChannelId -> IO a)- -- ^ the asynchronous Mattermost channel-based IO operation- -> (ChannelId -> a -> MH ())- -- ^ function to process the results in brick event handling context- -> MH ()---- | Performs an asynchronous IO operation on a specific channel. On--- completion, the final argument a completion function is executed in--- an MH () context in the main (brick) thread.-doAsyncChannelMM :: DoAsyncChannelMM a-doAsyncChannelMM prio cId mmOp eventHandler =- doAsyncMM prio (\s t -> mmOp s t cId) (eventHandler cId)---- | Use this convenience function if no operation needs to be--- performed in the MH state after an async operation completes.-endAsyncNOP :: ChannelId -> a -> MH ()-endAsyncNOP _ _ = return ()- -- * Client Messages messagesFromPosts :: Posts -> MH Messages@@ -180,7 +67,7 @@ | (pId, x) <- HM.toList (p^.postsPostsL) ] maybeFlag flagSet msg- | Just pId <- msg^.mPostId, pId `Set.member` flagSet+ | Just (MessagePostId pId) <- msg^.mMessageId, pId `Set.member` flagSet = msg & mFlagged .~ True | otherwise = msg -- n.b. postsOrder is most recent first@@ -194,93 +81,179 @@ Nothing -> error $ "BUG: could not find post for post ID " <> show pId Just post -> post -asyncFetchAttachments :: Post -> MH ()-asyncFetchAttachments p = do- let cId = (p^.postChannelIdL)- pId = (p^.postIdL)- session <- getSession- host <- use (csResources.crConn.cdHostnameL)- F.forM_ (p^.postFileIdsL) $ \fId -> doAsyncWith Normal $ do- info <- mmGetMetadataForFile fId session- let scheme = "https://"- attUrl = scheme <> host <> urlForFile fId- attachment = mkAttachment (fileInfoName info) attUrl fId- addIfMissing a as =- if isNothing $ Seq.elemIndexL a as- then a Seq.<| as- else as- addAttachment m- | m^.mPostId == Just pId =- m & mAttachments %~ (addIfMissing attachment)- | otherwise = m- return $- csChannel(cId).ccContents.cdMessages.traversed %= addAttachment- -- | Add a 'ClientMessage' to the current channel's message list addClientMessage :: ClientMessage -> MH () addClientMessage msg = do cid <- use csCurrentChannelId- let addCMsg = ccContents.cdMessages %~ (addMessage $ clientMessageToMessage msg)+ uuid <- generateUUID+ let addCMsg = ccContents.cdMessages %~+ (addMessage $ clientMessageToMessage msg & mMessageId .~ Just (MessageUUID uuid)) csChannels %= modifyChannelById cid addCMsg + let msgTy = case msg^.cmType of+ Error -> LogError+ _ -> LogGeneral++ mhLog msgTy $ T.pack $ show msg+ -- | Add a new 'ClientMessage' representing an error message to -- the current channel's message list postInfoMessage :: Text -> MH ()-postInfoMessage err = addClientMessage =<< newClientMessage Informative err+postInfoMessage info =+ addClientMessage =<< newClientMessage Informative (sanitizeUserText' info) -- | Add a new 'ClientMessage' representing an error message to -- the current channel's message list postErrorMessage' :: Text -> MH ()-postErrorMessage' err = addClientMessage =<< newClientMessage Error err---- | Raise a rich error-mhError :: MHError -> MH ()-mhError err = raiseInternalEvent (DisplayError err)+postErrorMessage' err =+ addClientMessage =<< newClientMessage Error (sanitizeUserText' err) postErrorMessageIO :: Text -> ChatState -> IO ChatState postErrorMessageIO err st = do msg <- newClientMessage Error err+ uuid <- generateUUID_IO let cId = st ^. csCurrentChannelId- addEMsg = ccContents.cdMessages %~ (addMessage $ clientMessageToMessage msg)+ addEMsg = ccContents.cdMessages %~+ (addMessage $ clientMessageToMessage msg & mMessageId .~ Just (MessageUUID uuid)) return $ st & csChannels %~ modifyChannelById cId addEMsg -numScrollbackPosts :: Int-numScrollbackPosts = 100+openURL :: LinkChoice -> MH Bool+openURL link = do+ cfg <- use (csResources.crConfiguration)+ case configURLOpenCommand cfg of+ Nothing ->+ return False+ Just urlOpenCommand -> do+ session <- getSession -asyncFetchReactionsForPost :: ChannelId -> Post -> MH ()-asyncFetchReactionsForPost cId p- | not (p^.postHasReactionsL) = return ()- | otherwise = doAsyncChannelMM Normal cId- (\s _ _ -> fmap toList (mmGetReactionsForPost (p^.postIdL) s))- addReactions+ -- Is the URL referring to an attachment?+ let act = case link^.linkFileId of+ Nothing -> prepareLink link+ Just fId -> prepareAttachment fId session -addReactions :: ChannelId -> [Reaction] -> MH ()-addReactions cId rs = csChannel(cId).ccContents.cdMessages %= fmap upd- where upd msg = msg & mReactions %~ insertAll (msg^.mPostId)- insert pId r- | pId == Just (r^.reactionPostIdL) = Map.insertWith (+) (r^.reactionEmojiNameL) 1- | otherwise = id- insertAll pId msg = foldr (insert pId) msg rs+ -- Is the URL-opening command interactive? If so, pause+ -- Matterhorn and run the opener interactively. Otherwise+ -- run the opener asynchronously and continue running+ -- Matterhorn interactively.+ case configURLOpenCommandInteractive cfg of+ False -> do+ outputChan <- use (csResources.crSubprocessLog)+ doAsyncWith Preempt $ do+ args <- act+ runLoggedCommand False outputChan (T.unpack urlOpenCommand)+ args Nothing Nothing+ return $ return ()+ True -> do+ -- If there isn't a new message cutoff showing in+ -- the current channel, set one. This way, while the+ -- user is gone using their interactive URL opener,+ -- when they return, any messages that arrive in the+ -- current channel will be displayed as new.+ curChan <- use csCurrentChannel+ let msgs = curChan^.ccContents.cdMessages+ case findLatestUserMessage isEditable msgs of+ Nothing -> return ()+ Just m ->+ case m^.mOriginalPost of+ Nothing -> return ()+ Just p ->+ case curChan^.ccInfo.cdNewMessageIndicator of+ Hide ->+ csCurrentChannel.ccInfo.cdNewMessageIndicator .= (NewPostsAfterServerTime (p^.postCreateAtL))+ _ -> return ()+ -- No need to add a gap here: the websocket+ -- disconnect/reconnect events will automatically+ -- handle management of messages delivered while+ -- suspended. -removeReaction :: Reaction -> ChannelId -> MH ()-removeReaction r cId = csChannel(cId).ccContents.cdMessages %= fmap upd- where upd m | m^.mPostId == Just (r^.reactionPostIdL) =- m & mReactions %~ (Map.insertWith (+) (r^.reactionEmojiNameL) (-1))- | otherwise = m+ mhSuspendAndResume $ \st -> do+ args <- act+ void $ runInteractiveCommand (T.unpack urlOpenCommand) args+ return $ setMode' Main st -copyToClipboard :: Text -> MH ()-copyToClipboard txt = do- result <- liftIO (try (setClipboard (T.unpack txt)))- case result of- Left e -> do- let errMsg = case e of- UnsupportedOS _ ->- "Matterhorn does not support yanking on this operating system."- NoTextualData ->- "Textual data is required to set the clipboard."- MissingCommands cmds ->- "Could not set clipboard due to missing one of the " <>- "required program(s): " <> (T.pack $ show cmds)- mhError $ ClipboardError errMsg- Right () ->- return ()+ return True++runInteractiveCommand :: String+ -> [String]+ -> IO (Either String ExitCode)+runInteractiveCommand cmd args = do+ let opener = (proc cmd args) { std_in = Inherit+ , std_out = Inherit+ , std_err = Inherit+ }+ result <- try $ createProcess opener+ case result of+ Left (e::SomeException) -> return $ Left $ show e+ Right (_, _, _, ph) -> do+ ec <- waitForProcess ph+ return $ Right ec++runLoggedCommand :: Bool+ -- ^ Whether stdout output is expected for this program+ -> STM.TChan ProgramOutput+ -- ^ The output channel to send the output to+ -> String+ -- ^ The program name+ -> [String]+ -- ^ Arguments+ -> Maybe String+ -- ^ The stdin to send, if any+ -> Maybe (MVar ProgramOutput)+ -- ^ Where to put the program output when it is ready+ -> IO ()+runLoggedCommand stdoutOkay outputChan cmd args mInput mOutputVar = void $ forkIO $ do+ let stdIn = maybe NoStream (const CreatePipe) mInput+ opener = (proc cmd args) { std_in = stdIn+ , std_out = CreatePipe+ , std_err = CreatePipe+ }+ result <- try $ createProcess opener+ case result of+ Left (e::SomeException) -> do+ let po = ProgramOutput cmd args "" stdoutOkay (show e) (ExitFailure 1)+ STM.atomically $ STM.writeTChan outputChan po+ maybe (return ()) (flip putMVar po) mOutputVar+ Right (stdinResult, Just outh, Just errh, ph) -> do+ case stdinResult of+ Just inh -> do+ let Just input = mInput+ hPutStrLn inh input+ hFlush inh+ Nothing -> return ()++ ec <- waitForProcess ph+ outResult <- hGetContents outh+ errResult <- hGetContents errh+ let po = ProgramOutput cmd args outResult stdoutOkay errResult ec+ STM.atomically $ STM.writeTChan outputChan po+ maybe (return ()) (flip putMVar po) mOutputVar+ Right _ ->+ error $ "BUG: createProcess returned unexpected result, report this at " <>+ "https://github.com/matterhorn-chat/matterhorn"++prepareLink :: LinkChoice -> IO [String]+prepareLink link = return [T.unpack $ link^.linkURL]++prepareAttachment :: FileId -> Session -> IO [String]+prepareAttachment fId sess = do+ -- The link is for an attachment, so fetch it and then+ -- open the local copy.++ (info, contents) <- concurrently (mmGetMetadataForFile fId sess) (mmGetFile fId sess)+ cacheDir <- getUserCacheDir xdgName++ let dir = cacheDir </> "files" </> T.unpack (idString fId)+ fname = dir </> T.unpack (fileInfoName info)++ createDirectoryIfMissing True dir+ BS.writeFile fname contents+ return [fname]++removeEmoteFormatting :: T.Text -> T.Text+removeEmoteFormatting t+ | "*" `T.isPrefixOf` t &&+ "*" `T.isSuffixOf` t = T.init $ T.drop 1 t+ | otherwise = t++addEmoteFormatting :: T.Text -> T.Text+addEmoteFormatting t = "*" <> t <> "*"
src/State/Editing.hs view
@@ -1,7 +1,15 @@ {-# LANGUAGE MultiWayIf #-} {-# LANGUAGE RecordWildCards #-}--module State.Editing where+module State.Editing+ ( requestSpellCheck+ , editingKeybindings+ , toggleMessagePreview+ , toggleMultilineEditing+ , invokeExternalEditor+ , handlePaste+ , handleEditingInput+ )+where import Prelude () import Prelude.MH
+ src/State/Flagging.hs view
@@ -0,0 +1,65 @@+module State.Flagging+ ( loadFlaggedMessages+ , updateMessageFlag+ )+where++import Prelude ()+import Prelude.MH++import Data.Function ( on )+import qualified Data.Set as Set+import Lens.Micro.Platform++import Network.Mattermost.Types++import State.Common+import Types+++loadFlaggedMessages :: Seq FlaggedPost -> ChatState -> IO ()+loadFlaggedMessages prefs st = doAsyncWithIO Normal st $ do+ return $ sequence_ [ updateMessageFlag (flaggedPostId fp) True+ | fp <- toList prefs+ , flaggedPostStatus fp+ ]+++-- | 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+-- us of flagged or unflagged messages.+updateMessageFlag :: PostId -> Bool -> MH ()+updateMessageFlag pId f = do+ if f+ then csResources.crFlaggedPosts %= Set.insert pId+ else csResources.crFlaggedPosts %= Set.delete pId+ msgMb <- use (csPostMap.at(pId))+ case msgMb of+ Just msg+ | Just cId <- msg^.mChannelId -> do+ let isTargetMessage m = m^.mMessageId == Just (MessagePostId pId)+ csChannel(cId).ccContents.cdMessages.traversed.filtered isTargetMessage.mFlagged .= f+ csPostMap.ix(pId).mFlagged .= f+ -- We also want to update the post overlay if this happens while+ -- we're we're observing it+ mode <- gets appMode+ case mode of+ PostListOverlay PostListFlagged+ | f ->+ csPostListOverlay.postListPosts %=+ addMessage (msg & mFlagged .~ True)+ -- deleting here is tricky, because it means that we need to+ -- move the focus somewhere: we'll try moving it _up_ unless+ -- we can't, in which case we'll try moving it down.+ | otherwise -> do+ selId <- use (csPostListOverlay.postListSelected)+ posts <- use (csPostListOverlay.postListPosts)+ let nextId = case getNextPostId selId posts of+ Nothing -> getPrevPostId selId posts+ Just x -> Just x+ csPostListOverlay.postListSelected .= nextId+ csPostListOverlay.postListPosts %=+ filterMessages (((/=) `on` _mMessageId) msg)+ _ -> return ()+ _ -> return ()
+ src/State/Help.hs view
@@ -0,0 +1,17 @@+module State.Help+ ( showHelpScreen+ )+where++import Prelude ()+import Prelude.MH++import Brick.Main ( viewportScroll, vScrollToBeginning )++import Types+++showHelpScreen :: HelpTopic -> MH ()+showHelpScreen topic = do+ mh $ vScrollToBeginning (viewportScroll HelpViewport)+ setMode $ ShowHelp topic
+ src/State/Logging.hs view
@@ -0,0 +1,33 @@+module State.Logging+ ( startLogging+ , stopLogging+ , logSnapshot+ , getLogDestination+ )+where++import Prelude ()+import Prelude.MH++import Types+++startLogging :: FilePath -> MH ()+startLogging path = do+ mgr <- use (csResources.crLogManager)+ liftIO $ startLoggingToFile mgr path++stopLogging :: MH ()+stopLogging = do+ mgr <- use (csResources.crLogManager)+ liftIO $ stopLoggingToFile mgr++logSnapshot :: FilePath -> MH ()+logSnapshot path = do+ mgr <- use (csResources.crLogManager)+ liftIO $ requestLogSnapshot mgr path++getLogDestination :: MH ()+getLogDestination = do+ mgr <- use (csResources.crLogManager)+ liftIO $ requestLogDestination mgr
+ src/State/MessageSelect.hs view
@@ -0,0 +1,245 @@+module State.MessageSelect+ (+ -- * Message selection mode+ beginMessageSelect+ , flagSelectedMessage+ , viewSelectedMessage+ , yankSelectedMessageVerbatim+ , yankSelectedMessage+ , openSelectedMessageURLs+ , beginConfirmDeleteSelectedMessage+ , messageSelectUp+ , messageSelectUpBy+ , messageSelectDown+ , messageSelectDownBy+ , deleteSelectedMessage+ , beginReplyCompose+ , beginEditMessage+ , getSelectedMessage+ , cancelReplyOrEdit+ , replyToLatestMessage+ , flagMessage+ )+where++import Prelude ()+import Prelude.MH++import Brick ( invalidateCacheEntry )+import Brick.Main ( viewportScroll, hScrollToBeginning+ , vScrollToBeginning )+import Brick.Widgets.Edit ( applyEdit )+import Data.Text.Zipper ( clearZipper, insertMany )+import Lens.Micro.Platform++import qualified Network.Mattermost.Endpoints as MM+import Network.Mattermost.Types++import Clipboard ( copyToClipboard )+import Markdown ( findVerbatimChunk )+import Types+import Types.Common+import State.Common+++getSelectedMessage :: ChatState -> Maybe Message+getSelectedMessage st+ | appMode st /= MessageSelect && appMode st /= MessageSelectDeleteConfirm = Nothing+ | otherwise = do+ selMsgId <- selectMessageId $ st^.csMessageSelect+ let chanMsgs = st ^. csCurrentChannel . ccContents . cdMessages+ findMessage selMsgId chanMsgs++beginMessageSelect :: MH ()+beginMessageSelect = do+ -- Get the number of messages in the current channel and set the+ -- currently selected message index to be the most recently received+ -- message that corresponds to a Post (i.e. exclude informative+ -- messages).+ --+ -- If we can't find one at all, we ignore the mode switch request+ -- and just return.+ chanMsgs <- use(csCurrentChannel . ccContents . cdMessages)+ let recentMsg = getLatestSelectableMessage chanMsgs++ when (isJust recentMsg) $ do+ setMode MessageSelect+ csMessageSelect .= MessageSelectState (recentMsg >>= _mMessageId)++-- | Tell the server that the message we currently have selected+-- should have its flagged state toggled.+flagSelectedMessage :: MH ()+flagSelectedMessage = do+ selected <- use (to getSelectedMessage)+ case selected of+ Just msg+ | isFlaggable msg, Just pId <- messagePostId msg ->+ flagMessage pId (not (msg^.mFlagged))+ _ -> return ()++viewSelectedMessage :: MH ()+viewSelectedMessage = do+ selected <- use (to getSelectedMessage)+ case selected of+ Just msg -> viewMessage msg+ _ -> return ()++viewMessage :: Message -> MH ()+viewMessage m = do+ csViewedMessage .= Just m+ let vs = viewportScroll ViewMessageArea+ mh $ do+ vScrollToBeginning vs+ hScrollToBeginning vs+ invalidateCacheEntry ViewMessageArea+ setMode ViewMessage++yankSelectedMessageVerbatim :: MH ()+yankSelectedMessageVerbatim = do+ selectedMessage <- use (to getSelectedMessage)+ case selectedMessage of+ Nothing -> return ()+ Just m -> do+ setMode Main+ case findVerbatimChunk (m^.mText) of+ Just txt -> copyToClipboard txt+ Nothing -> return ()++yankSelectedMessage :: MH ()+yankSelectedMessage = do+ selectedMessage <- use (to getSelectedMessage)+ case selectedMessage of+ Nothing -> return ()+ Just m -> do+ setMode Main+ copyToClipboard $ m^.mMarkdownSource++openSelectedMessageURLs :: MH ()+openSelectedMessageURLs = whenMode MessageSelect $ do+ Just curMsg <- use (to getSelectedMessage)+ let urls = msgURLs curMsg+ when (not (null urls)) $ do+ openedAll <- and <$> mapM openURL urls+ case openedAll of+ True -> setMode Main+ False ->+ mhError $ ConfigOptionMissing "urlOpenCommand"++beginConfirmDeleteSelectedMessage :: MH ()+beginConfirmDeleteSelectedMessage = do+ st <- use id+ selected <- use (to getSelectedMessage)+ case selected of+ Just msg | isDeletable msg && isMine st msg ->+ setMode MessageSelectDeleteConfirm+ _ -> return ()++messageSelectUp :: MH ()+messageSelectUp = do+ mode <- gets appMode+ selected <- use (csMessageSelect.to selectMessageId)+ case selected of+ Just _ | mode == MessageSelect -> do+ chanMsgs <- use (csCurrentChannel.ccContents.cdMessages)+ let nextMsgId = getPrevMessageId selected chanMsgs+ csMessageSelect .= MessageSelectState (nextMsgId <|> selected)+ _ -> return ()++messageSelectDown :: MH ()+messageSelectDown = do+ selected <- use (csMessageSelect.to selectMessageId)+ case selected of+ Just _ -> whenMode MessageSelect $ do+ chanMsgs <- use (csCurrentChannel.ccContents.cdMessages)+ let nextMsgId = getNextMessageId selected chanMsgs+ csMessageSelect .= MessageSelectState (nextMsgId <|> selected)+ _ -> return ()++messageSelectDownBy :: Int -> MH ()+messageSelectDownBy amt+ | amt <= 0 = return ()+ | otherwise =+ messageSelectDown >> messageSelectDownBy (amt - 1)++messageSelectUpBy :: Int -> MH ()+messageSelectUpBy amt+ | amt <= 0 = return ()+ | otherwise =+ messageSelectUp >> messageSelectUpBy (amt - 1)++deleteSelectedMessage :: MH ()+deleteSelectedMessage = do+ selectedMessage <- use (to getSelectedMessage)+ st <- use id+ cId <- use csCurrentChannelId+ case selectedMessage of+ Just msg | isMine st msg && isDeletable msg ->+ case msg^.mOriginalPost of+ Just p ->+ doAsyncChannelMM Preempt cId+ (\s _ _ -> MM.mmDeletePost (postId p) s)+ (\_ _ -> do csEditState.cedEditMode .= NewPost+ setMode Main)+ Nothing -> return ()+ _ -> return ()++beginReplyCompose :: MH ()+beginReplyCompose = do+ selected <- use (to getSelectedMessage)+ case selected of+ Just msg | isReplyable msg -> do+ let Just p = msg^.mOriginalPost+ setMode Main+ csEditState.cedEditMode .= Replying msg p+ _ -> return ()++beginEditMessage :: MH ()+beginEditMessage = do+ selected <- use (to getSelectedMessage)+ st <- use id+ case selected of+ Just msg | isMine st msg && isEditable msg -> do+ let Just p = msg^.mOriginalPost+ setMode Main+ csEditState.cedEditMode .= Editing p (msg^.mType)+ -- If the post that we're editing is an emote, we need+ -- to strip the formatting because that's only there to+ -- indicate that the post is an emote. This is annoying and+ -- can go away one day when there is an actual post type+ -- value of "emote" that we can look at. Note that the+ -- removed formatting needs to be reinstated just prior to+ -- issuing the API call to update the post.+ let toEdit = if msg^.mType == CP Emote+ then removeEmoteFormatting $ sanitizeUserText $ postMessage p+ else sanitizeUserText $ postMessage p+ csEditState.cedEditor %= applyEdit (clearZipper >> (insertMany toEdit))+ _ -> return ()++cancelReplyOrEdit :: MH ()+cancelReplyOrEdit = do+ mode <- use (csEditState.cedEditMode)+ case mode of+ NewPost -> return ()+ _ -> do+ csEditState.cedEditMode .= NewPost+ csEditState.cedEditor %= applyEdit clearZipper++replyToLatestMessage :: MH ()+replyToLatestMessage = do+ msgs <- use (csCurrentChannel . ccContents . cdMessages)+ case findLatestUserMessage isReplyable msgs of+ Just msg | isReplyable msg ->+ do let Just p = msg^.mOriginalPost+ setMode Main+ csEditState.cedEditMode .= Replying msg p+ _ -> return ()++-- | Tell the server that we have flagged or unflagged a message.+flagMessage :: PostId -> Bool -> MH ()+flagMessage pId f = do+ session <- getSession+ myId <- gets myUserId+ doAsyncWith Normal $ do+ let doFlag = if f then MM.mmFlagPost else MM.mmUnflagPost+ doFlag myId pId session+ return $ return ()
src/State/Messages.hs view
@@ -1,26 +1,47 @@+{-# LANGUAGE MultiWayIf #-} module State.Messages- ( addDisconnectGaps- , loadFlaggedMessages- , updateMessageFlag- , lastMsg- )+ ( PostToAdd(..)+ , addDisconnectGaps+ , lastMsg+ , sendMessage+ , editMessage+ , deleteMessage+ , addNewPostedMessage+ , addMessageToState+ , addObtainedMessages+ , asyncFetchMoreMessages+ , fetchVisibleIfNeeded+ , disconnectChannels+ ) where import Prelude () import Prelude.MH -import Data.Function ( on )+import Brick.Main ( getVtyHandle, invalidateCacheEntry )+import qualified Data.Foldable as F+import qualified Data.HashMap.Strict as HM import qualified Data.Set as Set+import qualified Data.Sequence as Seq import qualified Data.Text as T-import Lens.Micro.Platform ( (.=), (%=), (%~), (.~), to, at- , traversed, filtered, ix )+import Graphics.Vty ( outputIface )+import Graphics.Vty.Output.Interface ( ringTerminalBell )+import Lens.Micro.Platform ( Traversal', (.=), (%=), (%~), (.~), (^?)+ , to, at, traversed, filtered, ix ) import Network.Mattermost+import qualified Network.Mattermost.Endpoints as MM+import Network.Mattermost.Lenses import Network.Mattermost.Types +import Constants import State.Common+import State.Channels+import State.Reactions+import State.Users import TimeUtils import Types+import Types.Common ( sanitizeUserText ) -- ----------------------------------------------------------------------@@ -40,10 +61,14 @@ where onEach c = do addEndGap c clearPendingFlags c +-- | Websocket was disconnected, so all channels may now miss some+-- messages+disconnectChannels :: MH ()+disconnectChannels = addDisconnectGaps+ clearPendingFlags :: ChannelId -> MH () clearPendingFlags c = csChannel(c).ccContents.cdFetchPending .= False - addEndGap :: ChannelId -> MH () addEndGap cId = withChannel cId $ \chan -> let lastmsg_ = chan^.ccContents.cdMessages.to reverseMessages.to lastMsg@@ -55,57 +80,486 @@ in unless lastIsGap (csChannels %= modifyChannelById cId (ccContents.cdMessages %~ addMessage gapMsg)) - lastMsg :: RetrogradeMessages -> Maybe Message lastMsg = withFirstMessage id +sendMessage :: EditMode -> Text -> MH ()+sendMessage mode msg =+ case shouldSkipMessage msg of+ True -> return ()+ False -> do+ status <- use csConnectionStatus+ st <- use id+ case status of+ Disconnected -> do+ let m = "Cannot send messages while disconnected."+ mhError $ GenericError m+ Connected -> do+ let chanId = st^.csCurrentChannelId+ session <- getSession+ doAsync Preempt $ do+ case mode of+ NewPost -> do+ let pendingPost = rawPost msg chanId+ void $ MM.mmCreatePost pendingPost session+ Replying _ p -> do+ let pendingPost = (rawPost msg chanId) { rawPostRootId = postRootId p <|> (Just $ postId p) }+ void $ MM.mmCreatePost pendingPost session+ Editing p ty -> do+ let body = if ty == CP Emote+ then addEmoteFormatting msg+ else msg+ void $ MM.mmPatchPost (postId p) (postUpdateBody body) session --- ------------------------------------------------------------------------- Flagged messages+shouldSkipMessage :: Text -> Bool+shouldSkipMessage "" = True+shouldSkipMessage s = T.all (`elem` (" \t"::String)) s +editMessage :: Post -> MH ()+editMessage new = do+ myId <- gets myUserId+ let isEditedMessage m = m^.mMessageId == Just (MessagePostId $ new^.postIdL)+ msg = clientPostToMessage (toClientPost new (new^.postParentIdL))+ chan = csChannel (new^.postChannelIdL)+ chan . ccContents . cdMessages . traversed . filtered isEditedMessage .= msg -loadFlaggedMessages :: Seq FlaggedPost -> ChatState -> IO ()-loadFlaggedMessages prefs st = doAsyncWithIO Normal st $ do- return $ sequence_ [ updateMessageFlag (flaggedPostId fp) True- | fp <- toList prefs- , flaggedPostStatus fp- ]+ when (postUserId new /= Just myId) $+ chan %= adjustEditedThreshold new --- | 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--- us of flagged or unflagged messages.-updateMessageFlag :: PostId -> Bool -> MH ()-updateMessageFlag pId f = do- if f- then csResources.crFlaggedPosts %= Set.insert pId- else csResources.crFlaggedPosts %= Set.delete pId- msgMb <- use (csPostMap.at(pId))- case msgMb of- Just msg- | Just cId <- msg^.mChannelId -> do- let isTargetMessage m = m^.mPostId == Just pId- csChannel(cId).ccContents.cdMessages.traversed.filtered isTargetMessage.mFlagged .= f- csPostMap.ix(pId).mFlagged .= f- -- We also want to update the post overlay if this happens while- -- we're we're observing it- mode <- gets appMode- case mode of- PostListOverlay PostListFlagged- | f ->- csPostListOverlay.postListPosts %=- addMessage (msg & mFlagged .~ True)- -- deleting here is tricky, because it means that we need to- -- move the focus somewhere: we'll try moving it _up_ unless- -- we can't, in which case we'll try moving it down.- | otherwise -> do- selId <- use (csPostListOverlay.postListSelected)- posts <- use (csPostListOverlay.postListPosts)- let nextId = case getNextPostId selId posts of- Nothing -> getPrevPostId selId posts- Just x -> Just x- csPostListOverlay.postListSelected .= nextId- csPostListOverlay.postListPosts %=- filterMessages (((/=) `on` _mPostId) msg)- _ -> return ()- _ -> return ()+ csPostMap.ix(postId new) .= msg+ asyncFetchReactionsForPost (postChannelId new) new+ asyncFetchAttachments new+ cId <- use csCurrentChannelId+ when (postChannelId new == cId) updateViewed++deleteMessage :: Post -> MH ()+deleteMessage new = do+ let isDeletedMessage m = m^.mMessageId == Just (MessagePostId $ new^.postIdL) ||+ isReplyTo (new^.postIdL) m+ chan :: Traversal' ChatState ClientChannel+ chan = csChannel (new^.postChannelIdL)+ chan.ccContents.cdMessages.traversed.filtered isDeletedMessage %= (& mDeleted .~ True)+ chan %= adjustUpdated new+ cId <- use csCurrentChannelId+ when (postChannelId new == cId) updateViewed++addNewPostedMessage :: PostToAdd -> MH ()+addNewPostedMessage p =+ addMessageToState p >>= postProcessMessageAdd++addObtainedMessages :: ChannelId -> Int -> Posts -> MH PostProcessMessageAdd+addObtainedMessages cId reqCnt posts = do+ -- Adding a block of server-provided messages, which are known to+ -- be contiguous. Locally this may overlap with some UnknownGap+ -- messages, which can therefore be removed. Alternatively the+ -- new block may be discontiguous with the local blocks, in which+ -- case the new block should be surrounded by UnknownGaps.+ withChannelOrDefault cId NoAction $ \chan -> do+ let pIdList = toList (posts^.postsOrderL)+ -- the first and list PostId in the batch to be added+ earliestPId = last pIdList+ latestPId = head pIdList+ earliestDate = postCreateAt $ (posts^.postsPostsL) HM.! earliestPId+ latestDate = postCreateAt $ (posts^.postsPostsL) HM.! latestPId++ localMessages = chan^.ccContents . cdMessages++ match = snd $ removeMatchesFromSubset+ (\m -> maybe False (\p -> p `elem` pIdList) (messagePostId m))+ (Just (MessagePostId earliestPId))+ (Just (MessagePostId latestPId))+ localMessages++ accum m l =+ case messagePostId m of+ Just pId -> pId : l+ Nothing -> l+ dupPIds = foldr accum [] match++ -- If there were any matches, then there was overlap of+ -- the new messages with existing messages.++ -- Don't re-add matching messages (avoid overhead like+ -- re-checking/re-fetching related post information, and+ -- do not signal action needed for notifications), and+ -- remove any gaps in the overlapping region.++ newGapMessage d = newMessageOfType "Additional messages???" (C UnknownGap) d++ -- If this batch contains the latest known messages, do+ -- not add a following gap. A gap at this point is added+ -- by a websocket disconnect, and any fetches thereafter+ -- are assumed to be the most current information (until+ -- another disconnect), so no gap is needed.+ -- Additionally, the presence of a gap at the end for a+ -- connected client causes a fetch of messages at this+ -- location, so adding the gap here would cause an+ -- infinite update loop.++ addingAtEnd = maybe True ((<=) latestDate) $+ (^.mDate) <$> getLatestPostMsg localMessages++ addingAtStart = maybe True ((>=) earliestDate) $+ (^.mDate) <$> getEarliestPostMsg localMessages+ removeStart = if addingAtStart && noMoreBefore then Nothing else Just (MessagePostId earliestPId)+ removeEnd = if addingAtEnd then Nothing else Just (MessagePostId latestPId)++ noMoreBefore = reqCnt < 0 && length pIdList < (-reqCnt)+ noMoreAfter = reqCnt > 0 && length pIdList < reqCnt++ -- The post map returned by the server will *already* have+ -- all thread messages for each post that is part of a+ -- thread. By calling messagesFromPosts here, we go ahead and+ -- populate the csPostMap with those posts so that below, in+ -- addMessageToState, we notice that we already know about reply+ -- parent messages and can avoid fetching them. This converts+ -- the posts to Messages and stores those and also returns+ -- them, but we don't need them here. We just want the post map+ -- update.+ void $ messagesFromPosts posts++ -- Add all the new *unique* posts into the existing channel+ -- corpus, generating needed fetches of data associated with+ -- the post, and determining an notification action to be+ -- taken (if any).+ action <- foldr andProcessWith NoAction <$>+ mapM (addMessageToState . OldPost)+ [ (posts^.postsPostsL) HM.! p+ | p <- toList (posts^.postsOrderL)+ , not (p `elem` dupPIds)+ ]++ csChannels %= modifyChannelById cId+ (ccContents.cdMessages %~ (fst . removeMatchesFromSubset isGap removeStart removeEnd))++ -- Add a gap at each end of the newly fetched data, unless:+ -- 1. there is an overlap+ -- 2. there is no more in the indicated direction+ -- a. indicated by adding messages later than any currently+ -- held messages (see note above re 'addingAtEnd').+ -- b. the amount returned was less than the amount requested++ unless (earliestPId `elem` dupPIds || noMoreBefore) $+ let gapMsg = newGapMessage (justBefore earliestDate)+ in csChannels %= modifyChannelById cId+ (ccContents.cdMessages %~ addMessage gapMsg)++ unless (latestPId `elem` dupPIds || addingAtEnd || noMoreAfter) $+ let gapMsg = newGapMessage (justAfter latestDate)+ in csChannels %= modifyChannelById cId+ (ccContents.cdMessages %~ addMessage gapMsg)++ -- Now initiate fetches for use information for any+ -- as-yet-unknown users related to this new set of messages+ let users = foldr (\post s -> maybe s (flip Set.insert s) (postUserId post))+ Set.empty (posts^.postsPostsL)+ addUnknownUsers inputUserIds = do+ knownUserIds <- Set.fromList <$> gets allUserIds+ let unknownUsers = Set.difference inputUserIds knownUserIds+ if Set.null unknownUsers+ then return ()+ else handleNewUsers $ Seq.fromList $ toList unknownUsers++ addUnknownUsers users++ -- Return the aggregated user notification action needed+ -- relative to the set of added messages.++ return action++-- | Adds a possibly new message to the associated channel contents.+-- Returns an indicator of whether the user should be potentially+-- notified of a change (a new message not posted by this user, a+-- mention of the user, etc.). This operation has no effect on any+-- existing UnknownGap entries and should be called when those are+-- irrelevant.+addMessageToState :: PostToAdd -> MH PostProcessMessageAdd+addMessageToState newPostData = do+ let (new, wasMentioned) = case newPostData of+ -- A post from scrollback history has no mention data, and+ -- that's okay: we only need to track mentions to tell the+ -- user that recent posts contained mentions.+ OldPost p -> (p, False)+ RecentPost p m -> (p, m)++ st <- use id+ case st ^? csChannel(postChannelId new) of+ Nothing -> do+ session <- getSession+ doAsyncWith Preempt $ do+ nc <- MM.mmGetChannel (postChannelId new) session+ member <- MM.mmGetChannelMember (postChannelId new) UserMe session++ let chType = nc^.channelTypeL+ pref = showGroupChannelPref (postChannelId new) (myUserId st)++ -- If the channel has been archived, we don't want to+ -- post this message or add the channel to the state.+ case channelDeleted nc of+ True -> return $ return ()+ False -> return $ do+ -- If the incoming message is for a group+ -- channel we don't know about, that's because+ -- it was previously hidden by the user. We need+ -- to show it, and to do that we need to update+ -- the server-side preference. (That, in turn,+ -- triggers a channel refresh.)+ if chType == Group+ then applyPreferenceChange pref+ else refreshChannel nc member++ addMessageToState newPostData >>= postProcessMessageAdd++ return NoAction+ Just _ -> do+ let cp = toClientPost new (new^.postParentIdL)+ fromMe = (cp^.cpUser == (Just $ myUserId st)) &&+ (isNothing $ cp^.cpUserOverride)+ userPrefs = st^.csResources.crUserPreferences+ isJoinOrLeave = case cp^.cpType of+ Join -> True+ Leave -> True+ _ -> False+ ignoredJoinLeaveMessage =+ not (userPrefs^.userPrefShowJoinLeave) && isJoinOrLeave+ cId = postChannelId new++ doAddMessage = do+ currCId <- use csCurrentChannelId+ flags <- use (csResources.crFlaggedPosts)+ let msg' = clientPostToMessage cp+ & mFlagged .~ ((cp^.cpPostId) `Set.member` flags)+ csPostMap.at(postId new) .= Just msg'+ csChannels %= modifyChannelById cId+ ((ccContents.cdMessages %~ addMessage msg') .+ (adjustUpdated new) .+ (\c -> if currCId == cId+ then c+ else updateNewMessageIndicator new c) .+ (\c -> if wasMentioned+ then c & ccInfo.cdMentionCount %~ succ+ else c)+ )+ asyncFetchReactionsForPost cId new+ asyncFetchAttachments new+ postedChanMessage++ doHandleAddedMessage = do+ -- If the message is in reply to another message,+ -- try to find it in the scrollback for the post's+ -- channel. If the message isn't there, fetch it. If+ -- we have to fetch it, don't post this message to the+ -- channel until we have fetched the parent.+ case cp^.cpInReplyToPost of+ Just parentId ->+ case getMessageForPostId st parentId of+ Nothing -> do+ doAsyncChannelMM Preempt cId+ (\s _ _ -> MM.mmGetThread parentId s)+ (\_ p -> do+ let postMap = HM.fromList [ ( pId+ , clientPostToMessage+ (toClientPost x (x^.postParentIdL))+ )+ | (pId, x) <- HM.toList (p^.postsPostsL)+ ]+ csPostMap %= HM.union postMap+ )+ _ -> return ()+ _ -> return ()++ doAddMessage++ postedChanMessage =+ withChannelOrDefault (postChannelId new) NoAction $ \chan -> do+ currCId <- use csCurrentChannelId++ let notifyPref = notifyPreference (myUser st) chan+ curChannelAction = if postChannelId new == currCId+ then UpdateServerViewed+ else NoAction+ originUserAction =+ if | fromMe -> NoAction+ | ignoredJoinLeaveMessage -> NoAction+ | notifyPref == NotifyOptionAll -> NotifyUser [newPostData]+ | notifyPref == NotifyOptionMention+ && wasMentioned -> NotifyUser [newPostData]+ | otherwise -> NoAction++ return $ curChannelAction `andProcessWith` originUserAction++ doHandleAddedMessage++-- | PostProcessMessageAdd is an internal value that informs the main+-- code whether the user should be notified (e.g., ring the bell) or+-- the server should be updated (e.g., that the channel has been+-- viewed). This is a monoid so that it can be folded over when there+-- are multiple inbound posts to be processed.+data PostProcessMessageAdd = NoAction+ | NotifyUser [PostToAdd]+ | UpdateServerViewed+ | NotifyUserAndServer [PostToAdd]++andProcessWith+ :: PostProcessMessageAdd -> PostProcessMessageAdd -> PostProcessMessageAdd+andProcessWith NoAction x = x+andProcessWith x NoAction = x+andProcessWith (NotifyUserAndServer p) UpdateServerViewed = NotifyUserAndServer p+andProcessWith (NotifyUserAndServer p1) (NotifyUser p2) = NotifyUserAndServer (p1 <> p2)+andProcessWith (NotifyUserAndServer p1) (NotifyUserAndServer p2) = NotifyUserAndServer (p1 <> p2)+andProcessWith (NotifyUser p1) (NotifyUserAndServer p2) = NotifyUser (p1 <> p2)+andProcessWith (NotifyUser p1) (NotifyUser p2) = NotifyUser (p1 <> p2)+andProcessWith (NotifyUser p) UpdateServerViewed = NotifyUserAndServer p+andProcessWith UpdateServerViewed UpdateServerViewed = UpdateServerViewed+andProcessWith UpdateServerViewed (NotifyUserAndServer p) = NotifyUserAndServer p+andProcessWith UpdateServerViewed (NotifyUser p) = NotifyUserAndServer p++-- | postProcessMessageAdd performs the actual actions indicated by+-- the corresponding input value.+postProcessMessageAdd :: PostProcessMessageAdd -> MH ()+postProcessMessageAdd ppma = postOp ppma+ where+ postOp NoAction = return ()+ postOp UpdateServerViewed = updateViewed+ postOp (NotifyUser p) = maybeRingBell >> mapM_ maybeNotify p+ postOp (NotifyUserAndServer p) = updateViewed >> maybeRingBell >> mapM_ maybeNotify p++maybeNotify :: PostToAdd -> MH ()+maybeNotify (OldPost _) = do+ return ()+maybeNotify (RecentPost post mentioned) = runNotifyCommand post mentioned++maybeRingBell :: MH ()+maybeRingBell = do+ doBell <- use (csResources.crConfiguration.to configActivityBell)+ when doBell $ do+ vty <- mh getVtyHandle+ liftIO $ ringTerminalBell $ outputIface vty++-- | When we add posts to the application state, we either get them+-- from the server during scrollback fetches (here called 'OldPost') or+-- we get them from websocket events when they are posted in real time+-- (here called 'RecentPost').+data PostToAdd =+ OldPost Post+ -- ^ A post from the server's history+ | RecentPost Post Bool+ -- ^ A message posted to the channel since the user connected, along+ -- with a flag indicating whether the post triggered any of the+ -- user's mentions. We need an extra flag because the server+ -- determines whether the post has any mentions, and that data is+ -- only available in websocket events (and then provided to this+ -- constructor).++runNotifyCommand :: Post -> Bool -> MH ()+runNotifyCommand post mentioned = do+ outputChan <- use (csResources.crSubprocessLog)+ st <- use id+ notifyCommand <- use (csResources.crConfiguration.to configActivityNotifyCommand)+ case notifyCommand of+ Nothing -> return ()+ Just cmd ->+ doAsyncWith Preempt $ do+ let messageString = T.unpack $ sanitizeUserText $ postMessage post+ notified = if mentioned then "1" else "2"+ sender = T.unpack $ maybePostUsername st post+ runLoggedCommand False outputChan (T.unpack cmd)+ [notified, sender, messageString] Nothing Nothing+ return $ return ()++maybePostUsername :: ChatState -> Post -> T.Text+maybePostUsername st p =+ fromMaybe T.empty $ do+ uId <- postUserId p+ usernameForUserId uId st++-- | Fetches additional message history for the current channel. This+-- is generally called when in ChannelScroll mode, in which state the+-- output is cached and seen via a scrolling viewport; new messages+-- received in this mode are not normally shown, but this explicit+-- user-driven fetch should be displayed, so this also invalidates the+-- cache.+asyncFetchMoreMessages :: MH ()+asyncFetchMoreMessages = do+ cId <- use csCurrentChannelId+ withChannel cId $ \chan ->+ let offset = max 0 $ length (chan^.ccContents.cdMessages) - 2+ -- Fetch more messages prior to any existing messages, but+ -- attempt to overlap with existing messages for+ -- determining contiguity or gaps. Back up two messages+ -- and request from there backward, which should include+ -- the last message in the response. This is an attempt+ -- to fetch *more* messages, so it's expected that there+ -- are at least 2 messages already here, but in case there+ -- aren't, just get another page from roughly the right+ -- location.+ first' = splitMessagesOn (isJust . messagePostId) (chan^.ccContents.cdMessages)+ second' = splitMessagesOn (isJust . messagePostId) $ snd $ snd first'+ query = MM.defaultPostQuery+ { MM.postQueryPage = Just (offset `div` pageAmount)+ , MM.postQueryPerPage = Just pageAmount+ }+ & \q -> case (fst first', fst second' >>= messagePostId) of+ (Just _, Just i) -> q { MM.postQueryBefore = Just i+ , MM.postQueryPage = Just 0+ }+ _ -> q+ in doAsyncChannelMM Preempt cId+ (\s _ c -> MM.mmGetPostsForChannel c query s)+ (\c p -> do addObtainedMessages c (-pageAmount) p >>= postProcessMessageAdd+ mh $ invalidateCacheEntry (ChannelMessages cId))++fetchVisibleIfNeeded :: MH ()+fetchVisibleIfNeeded = do+ sts <- use csConnectionStatus+ case sts of+ Connected -> do+ cId <- use csCurrentChannelId+ withChannel cId $ \chan ->+ let msgs = chan^.ccContents.cdMessages.to reverseMessages+ (numRemaining, gapInDisplayable, _, rel'pId, overlap) =+ foldl gapTrail (numScrollbackPosts, False, Nothing, Nothing, 2) msgs+ gapTrail a@(_, True, _, _, _) _ = a+ gapTrail a@(0, _, _, _, _) _ = a+ gapTrail (a, False, b, c, d) m | isGap m = (a, True, b, c, d)+ gapTrail (remCnt, _, prev'pId, prev''pId, ovl) msg =+ (remCnt - 1, False, msg^.mMessageId <|> prev'pId, prev'pId <|> prev''pId,+ ovl + if not (isPostMessage msg) then 1 else 0)+ numToReq = numRemaining + overlap+ query = MM.defaultPostQuery+ { MM.postQueryPage = Just 0+ , MM.postQueryPerPage = Just numToReq+ }+ finalQuery = case rel'pId of+ Just (MessagePostId pid) -> query { MM.postQueryBefore = Just pid }+ _ -> query+ op = \s _ c -> MM.mmGetPostsForChannel c finalQuery s+ in when ((not $ chan^.ccContents.cdFetchPending) && gapInDisplayable) $ do+ csChannel(cId).ccContents.cdFetchPending .= True+ doAsyncChannelMM Preempt cId op+ (\c p -> do addObtainedMessages c (-numToReq) p >>= postProcessMessageAdd+ csChannel(c).ccContents.cdFetchPending .= False)++ _ -> return ()++asyncFetchAttachments :: Post -> MH ()+asyncFetchAttachments p = do+ let cId = (p^.postChannelIdL)+ pId = (p^.postIdL)+ session <- getSession+ host <- use (csResources.crConn.cdHostnameL)+ F.forM_ (p^.postFileIdsL) $ \fId -> doAsyncWith Normal $ do+ info <- MM.mmGetMetadataForFile fId session+ let scheme = "https://"+ attUrl = scheme <> host <> urlForFile fId+ attachment = mkAttachment (fileInfoName info) attUrl fId+ addIfMissing a as =+ if isNothing $ Seq.elemIndexL a as+ then a Seq.<| as+ else as+ addAttachment m+ | m^.mMessageId == Just (MessagePostId pId) =+ m & mAttachments %~ (addIfMissing attachment)+ | otherwise = m+ return $+ csChannel(cId).ccContents.cdMessages.traversed %= addAttachment
src/State/PostListOverlay.hs view
@@ -1,4 +1,12 @@-module State.PostListOverlay where+module State.PostListOverlay+ ( enterFlaggedPostListMode+ , enterSearchResultPostListMode+ , postListSelectUp+ , postListSelectDown+ , postListUnflagSelected+ , exitPostListMode+ )+where import Prelude () import Prelude.MH@@ -8,8 +16,8 @@ import Network.Mattermost.Endpoints import Network.Mattermost.Types -import State import State.Common+import State.MessageSelect import Types import Types.DirectionalSeq (emptyDirSeq) @@ -19,7 +27,7 @@ enterPostListMode :: PostListContents -> Messages -> MH () enterPostListMode contents msgs = do csPostListOverlay.postListPosts .= msgs- csPostListOverlay.postListSelected .= join ((^.mPostId) <$> getLatestPostMsg msgs)+ csPostListOverlay.postListSelected .= (getLatestPostMsg msgs >>= messagePostId) setMode $ PostListOverlay contents -- | Clear out the state of a PostListOverlay
+ src/State/Reactions.hs view
@@ -0,0 +1,41 @@+module State.Reactions+ ( asyncFetchReactionsForPost+ , addReactions+ , removeReaction+ )+where++import Prelude ()+import Prelude.MH++import qualified Data.Map.Strict as Map+import Lens.Micro.Platform++import Network.Mattermost.Endpoints+import Network.Mattermost.Lenses+import Network.Mattermost.Types++import State.Async+import Types+++asyncFetchReactionsForPost :: ChannelId -> Post -> MH ()+asyncFetchReactionsForPost cId p+ | not (p^.postHasReactionsL) = return ()+ | otherwise = doAsyncChannelMM Normal cId+ (\s _ _ -> fmap toList (mmGetReactionsForPost (p^.postIdL) s))+ addReactions++addReactions :: ChannelId -> [Reaction] -> MH ()+addReactions cId rs = csChannel(cId).ccContents.cdMessages %= fmap upd+ where upd msg = msg & mReactions %~ insertAll (msg^.mMessageId)+ insert mId r+ | mId == Just (MessagePostId (r^.reactionPostIdL)) = Map.insertWith (+) (r^.reactionEmojiNameL) 1+ | otherwise = id+ insertAll mId msg = foldr (insert mId) msg rs++removeReaction :: Reaction -> ChannelId -> MH ()+removeReaction r cId = csChannel(cId).ccContents.cdMessages %= fmap upd+ where upd m | m^.mMessageId == Just (MessagePostId $ r^.reactionPostIdL) =+ m & mReactions %~ (Map.insertWith (+) (r^.reactionEmojiNameL) (-1))+ | otherwise = m
src/State/Setup.hs view
@@ -15,21 +15,20 @@ import Data.Maybe ( fromJust ) import qualified Data.Sequence as Seq import qualified Data.Text as T+import Data.Time.Clock ( getCurrentTime ) import Lens.Micro.Platform ( (%~) ) import System.Exit ( exitFailure ) import System.FilePath ( (</>), isRelative, dropFileName )-import System.IO ( Handle ) import System.IO.Error ( catchIOError ) import Network.Mattermost.Endpoints-import Network.Mattermost.Logging ( mmLoggerDebug ) import Network.Mattermost.Types import Config import InputHistory import LastRunState import Login-import State.Messages+import State.Flagging import State.Setup.Threads import TeamSelect import Themes@@ -56,17 +55,29 @@ `catchIOError` (\e -> return $ Left $ AuthIOError e) `catch` (\e -> return $ Left $ OtherAuthError e) -setupState :: Maybe Handle -> Config -> IO ChatState-setupState logFile initialConfig = do+apiLogEventToLogMessage :: LogEvent -> IO LogMessage+apiLogEventToLogMessage ev = do+ now <- getCurrentTime+ let msg = T.pack $ "Function: " <> logFunction ev <>+ ", event: " <> show (logEventType ev)+ return $ LogMessage { logMessageCategory = LogAPI+ , logMessageText = msg+ , logMessageContext = Nothing+ , logMessageTimestamp = now+ }++setupState :: Maybe FilePath -> Config -> IO ChatState+setupState mLogLocation initialConfig = do -- If we don't have enough credentials, ask for them. connInfo <- case getCredentials initialConfig of Nothing -> interactiveGatherCredentials (incompleteCredentials initialConfig) Nothing Just connInfo -> return connInfo - let setLogger = case logFile of- Nothing -> id- Just f -> \ cd -> cd `withLogger` mmLoggerDebug f+ eventChan <- newBChan 25+ logMgr <- newLogManager eventChan (configLogMaxBufferSize initialConfig) + let logApiEvent ev = apiLogEventToLogMessage ev >>= sendLogMessage logMgr+ setLogger cd = cd `withLogger` logApiEvent poolCfg = ConnectionPoolConfig { cpIdleConnTimeout = 60 , cpStripesCount = 1 , cpMaxConnCount = 5@@ -160,13 +171,19 @@ Right t -> return t requestChan <- STM.atomically STM.newTChan- eventChan <- newBChan 25 let cr = ChatResources session cd requestChan eventChan slc wac (themeToAttrMap custTheme) userStatusLock- userIdSet config mempty userPrefs mempty+ userIdSet config mempty userPrefs mempty logMgr - initializeState cr myTeam me+ st <- initializeState cr myTeam me++ -- If we got an initial log location, start logging there.+ case mLogLocation of+ Nothing -> return ()+ Just loc -> startLoggingToFile logMgr loc++ return st initializeState :: ChatResources -> Team -> User -> IO ChatState initializeState cr myTeam me = do
src/State/Setup/Threads.hs view
@@ -1,3 +1,4 @@+{-# LANGUAGE OverloadedStrings #-} module State.Setup.Threads ( startUserRefreshThread , startTypingUsersRefreshThread@@ -7,6 +8,7 @@ , maybeStartSpellChecker , startAsyncWorkerThread , startSyntaxMapLoaderThread+ , module State.Setup.Threads.Logging ) where @@ -19,6 +21,7 @@ import Control.Concurrent.STM.Delay import Control.Exception ( SomeException, try, finally, fromException ) import qualified Data.Foldable as F+import Data.List ( isInfixOf ) import qualified Data.Map as M import qualified Data.Text as T import Data.Time ( getCurrentTime, addUTCTime )@@ -34,8 +37,8 @@ import Network.Mattermost.Types import Constants-import State.Common import State.Editing ( requestSpellCheck )+import State.Setup.Threads.Logging import TimeUtils ( lookupLocalTimeZone ) import Types @@ -284,9 +287,19 @@ res <- try req case res of Left e -> do- let err = case fromException e of- Nothing -> AsyncErrEvent e- Just mmErr -> ServerError mmErr- writeBChan eventChan $ IEvent $ DisplayError err+ when (not $ shouldIgnore e) $ do+ let err = case fromException e of+ Nothing -> AsyncErrEvent e+ Just mmErr -> ServerError mmErr+ writeBChan eventChan $ IEvent $ DisplayError err Right upd -> writeBChan eventChan (RespEvent upd)++-- Filter for exceptions that we don't want to report to the user,+-- probably because they are not actionable and/or contain no useful+-- information.+--+-- E.g.+-- https://github.com/matterhorn-chat/matterhorn/issues/391+shouldIgnore :: SomeException -> Bool+shouldIgnore e = "getAddrInfo" `isInfixOf` show e
+ src/State/Setup/Threads/Logging.hs view
@@ -0,0 +1,256 @@+{-# LANGUAGE RecordWildCards #-}+-- | This module implements the logging thread. This thread can+-- optionally write logged messages to an output file. When the thread+-- is created, it is initially not writing to any output file and+-- must be told to do so by issuing a LogCommand using the LogManager+-- interface.+--+-- The logging thread has an internal bounded log message buffer. Logged+-- messages always get written to the buffer (potentially evicting old+-- messages to maintain the size bound). If the thread is also writing+-- to a file, such messages also get written to the file. When the+-- thread begins logging to a file, the entire buffer is written to the+-- file so that a historical snapshot of log activity can be saved in+-- cases where logging is turned on at runtime only once a problematic+-- behavior is observed.+module State.Setup.Threads.Logging+ ( newLogManager+ , shutdownLogManager+ )+where++import Prelude ()+import Prelude.MH++import Brick.BChan+import Control.Concurrent.Async ( Async, async, wait )+import qualified Control.Concurrent.STM as STM+import Control.Exception ( SomeException, try )+import Control.Monad.State.Strict+import qualified Data.Sequence as Seq+import qualified Data.Text as T+import Data.Time ( getCurrentTime )+import System.IO ( Handle, IOMode(AppendMode), hPutStr, hPutStrLn+ , hFlush, openFile, hClose )++import Types+++-- | The state of the logging thread.+data LogThreadState =+ LogThreadState { logThreadDestination :: Maybe (FilePath, Handle)+ -- ^ The logging thread's active logging destination.+ -- Nothing means log messages are not being written+ -- anywhere except the internal buffer.+ , logThreadEventChan :: BChan MHEvent+ -- ^ The application event channel that we'll use to+ -- notify of logging events.+ , logThreadCommandChan :: STM.TChan LogCommand+ -- ^ The channel on which the logging thread will+ -- wait for logging commands.+ , logThreadMessageBuffer :: Seq.Seq LogMessage+ -- ^ The internal bounded log message buffer.+ , logThreadMaxBufferSize :: Int+ -- ^ The size bound of the logThreadMessageBuffer.+ }++-- | Create a new log manager and start a logging thread for it.+newLogManager :: BChan MHEvent -> Int -> IO LogManager+newLogManager eventChan maxBufferSize = do+ chan <- STM.newTChanIO+ self <- startLoggingThread eventChan chan maxBufferSize+ let mgr = LogManager { logManagerCommandChannel = chan+ , logManagerHandle = self+ }+ return mgr++-- | Shuts down the log manager and blocks until shutdown is complete.+shutdownLogManager :: LogManager -> IO ()+shutdownLogManager mgr = do+ STM.atomically $ STM.writeTChan (logManagerCommandChannel mgr) ShutdownLogging+ wait $ logManagerHandle mgr++-- | The logging thread.+startLoggingThread :: BChan MHEvent -> STM.TChan LogCommand -> Int -> IO (Async ())+startLoggingThread eventChan logChan maxBufferSize = do+ let initialState = LogThreadState { logThreadDestination = Nothing+ , logThreadEventChan = eventChan+ , logThreadCommandChan = logChan+ , logThreadMessageBuffer = mempty+ , logThreadMaxBufferSize = maxBufferSize+ }+ async $ void $ runStateT logThreadBody initialState++logThreadBody :: StateT LogThreadState IO ()+logThreadBody = do+ cmd <- nextLogCommand+ continue <- handleLogCommand cmd+ when continue logThreadBody++-- | Get the next pending log thread command.+nextLogCommand :: StateT LogThreadState IO LogCommand+nextLogCommand = do+ chan <- gets logThreadCommandChan+ liftIO $ STM.atomically $ STM.readTChan chan++putMarkerMessage :: String -> Handle -> IO ()+putMarkerMessage msg h = do+ now <- getCurrentTime+ hPutStrLn h $ "[" <> show now <> "] " <> msg++-- | Emit a log stop marker to the file.+putLogEndMarker :: Handle -> IO ()+putLogEndMarker = putMarkerMessage "<<< Logging end >>>"++-- | Emit a log start marker to the file.+putLogStartMarker :: Handle -> IO ()+putLogStartMarker = putMarkerMessage "<<< Logging start >>>"++-- | Emit a log stop marker to the file and close it, then notify the+-- application that we have stopped logging.+finishLog :: BChan MHEvent -> FilePath -> Handle -> StateT LogThreadState IO ()+finishLog eventChan oldPath oldHandle = do+ liftIO $ do+ putLogEndMarker oldHandle+ hClose oldHandle+ writeBChan eventChan $ IEvent $ LoggingStopped oldPath+ modify $ \s -> s { logThreadDestination = Nothing }++stopLogging :: StateT LogThreadState IO ()+stopLogging = do+ oldDest <- gets logThreadDestination+ case oldDest of+ Nothing -> return ()+ Just (oldPath, oldHandle) -> do+ eventChan <- gets logThreadEventChan+ finishLog eventChan oldPath oldHandle++-- | Handle a single logging command.+handleLogCommand :: LogCommand -> StateT LogThreadState IO Bool+handleLogCommand (LogSnapshot path) = do+ -- LogSnapshot: write the current log message buffer to the+ -- specified path. Ignore the request if it is for the path that we+ -- are already logging to.+ eventChan <- gets logThreadEventChan+ dest <- gets logThreadDestination++ let shouldWrite = case dest of+ Nothing -> True+ Just (curPath, _) -> curPath /= path++ when shouldWrite $ do+ result <- liftIO $ try $ openFile path AppendMode+ case result of+ Left (e::SomeException) -> do+ liftIO $ writeBChan eventChan $ IEvent $ LogSnapshotFailed path (show e)+ Right handle -> do+ flushLogMessageBuffer handle+ liftIO $ hClose handle+ liftIO $ writeBChan eventChan $ IEvent $ LogSnapshotSucceeded path++ return True+handleLogCommand GetLogDestination = do+ -- GetLogDestination: the application asked us to provide the+ -- current log destination.+ dest <- gets logThreadDestination+ eventChan <- gets logThreadEventChan+ liftIO $ writeBChan eventChan $ IEvent $ LogDestination $ fst <$> dest+ return True+handleLogCommand ShutdownLogging = do+ -- ShutdownLogging: if we were logging to a file, close it. Then+ -- unlock the shutdown lock.+ stopLogging+ return False+handleLogCommand StopLogging = do+ -- StopLogging: if we were logging to a file, close it and notify+ -- the application. Otherwise do nothing.+ stopLogging+ return True+handleLogCommand (LogToFile newPath) = do+ -- LogToFile: if we were logging to a file, close that file, notify+ -- the application, then attempt to open the new file. If that+ -- failed, notify the application of the error. If it succeeded,+ -- start logging and notify the application.+ eventChan <- gets logThreadEventChan+ oldDest <- gets logThreadDestination++ shouldChange <- case oldDest of+ Nothing ->+ return True+ Just (oldPath, _) ->+ return (oldPath /= newPath)++ when shouldChange $ do+ result <- liftIO $ try $ openFile newPath AppendMode+ case result of+ Left (e::SomeException) -> liftIO $ do+ let msg = "Error in log thread: could not open " <> show newPath <>+ ": " <> show e+ writeBChan eventChan $ IEvent $ LogStartFailed newPath msg+ Right handle -> do+ stopLogging++ modify $ \s -> s { logThreadDestination = Just (newPath, handle) }+ flushLogMessageBuffer handle+ liftIO $ putLogStartMarker handle+ liftIO $ writeBChan eventChan $ IEvent $ LoggingStarted newPath++ return True+handleLogCommand (LogAMessage lm) = do+ -- LogAMessage: log a single message. Write the message to the+ -- bounded internal buffer (which may cause an older message to be+ -- evicted). Then, if we are actively logging to a file, write the+ -- message to that file and flush the output stream.+ maxBufSize <- gets logThreadMaxBufferSize++ let addMessageToBuffer s =+ -- Ensure that newSeq is always at most maxBufSize elements+ -- long.+ let newSeq = s Seq.|> lm+ toDrop = Seq.length s - maxBufSize+ in Seq.drop toDrop newSeq++ -- Append the message to the internal buffer, maintaining the bound+ -- on the internal buffer size.+ modify $ \s -> s { logThreadMessageBuffer = addMessageToBuffer (logThreadMessageBuffer s) }++ -- If we have an active log destination, write the message to the+ -- output file.+ dest <- gets logThreadDestination+ case dest of+ Nothing -> return ()+ Just (_, handle) -> liftIO $ do+ hPutLogMessage handle lm+ hFlush handle++ return True++-- | Write a single log message to the output handle.+hPutLogMessage :: Handle -> LogMessage -> IO ()+hPutLogMessage handle (LogMessage {..}) = do+ hPutStr handle $ "[" <> show logMessageTimestamp <> "] "+ hPutStr handle $ "[" <> show logMessageCategory <> "] "+ case logMessageContext of+ Nothing -> hPutStr handle "[No context] "+ Just c -> hPutStr handle $ "[" <> show c <> "] "+ hPutStrLn handle $ T.unpack logMessageText++-- | Flush the contents of the internal log message buffer.+flushLogMessageBuffer :: Handle -> StateT LogThreadState IO ()+flushLogMessageBuffer handle = do+ buf <- gets logThreadMessageBuffer+ when (Seq.length buf > 0) $ do+ liftIO $ do+ let firstLm = Seq.index buf 0+ lastLm = Seq.index buf (Seq.length buf - 1)+ mkMsg t m = "[" <> show t <> "] " <> m++ hPutStrLn handle $ mkMsg (logMessageTimestamp firstLm)+ "<<< Log message buffer begin >>>"++ forM_ buf (hPutLogMessage handle)++ hPutStrLn handle $ mkMsg (logMessageTimestamp lastLm)+ "<<< Log message buffer end >>>"++ hFlush handle
+ src/State/Themes.hs view
@@ -0,0 +1,33 @@+module State.Themes+ (+ listThemes+ , setTheme+ )+where++import Prelude ()+import Prelude.MH++import Brick.Themes ( themeToAttrMap )+import qualified Data.Text as T+import Lens.Micro.Platform ( (.=) )++import State.Common+import Themes+import Types+++listThemes :: MH ()+listThemes = do+ let themeList = T.intercalate "\n\n" $+ "Available built-in themes:" :+ ((" " <>) <$> internalThemeName <$> internalThemes)+ postInfoMessage themeList++setTheme :: Text -> MH ()+setTheme name =+ case lookupTheme name of+ Nothing -> listThemes+ Just it -> csResources.crTheme .=+ (themeToAttrMap $ internalTheme it)+
+ src/State/UrlSelect.hs view
@@ -0,0 +1,48 @@+module State.UrlSelect+ (+ -- * URL selection mode+ startUrlSelect+ , stopUrlSelect+ , openSelectedURL+ )+where++import Prelude ()+import Prelude.MH++import Brick.Widgets.List ( list, listMoveTo, listSelectedElement )+import qualified Data.Vector as V+import Lens.Micro.Platform ( (.=), to )++import State.Common+import Types+import Util+++startUrlSelect :: MH ()+startUrlSelect = do+ urls <- use (csCurrentChannel.to findUrls.to V.fromList)+ setMode UrlSelect+ csUrlList .= (listMoveTo (length urls - 1) $ list UrlList urls 2)++stopUrlSelect :: MH ()+stopUrlSelect = setMode Main++openSelectedURL :: MH ()+openSelectedURL = whenMode UrlSelect $ do+ selected <- use (csUrlList.to listSelectedElement)+ case selected of+ Nothing -> return ()+ Just (_, link) -> do+ opened <- openURL link+ when (not opened) $ do+ mhError $ ConfigOptionMissing "urlOpenCommand"+ setMode Main++findUrls :: ClientChannel -> [LinkChoice]+findUrls chan =+ let msgs = chan^.ccContents.cdMessages+ in removeDuplicates $ concat $ toList $ toList <$> msgURLs <$> msgs++removeDuplicates :: [LinkChoice] -> [LinkChoice]+removeDuplicates = nubOn (\ l -> (l^.linkURL, l^.linkUser))
src/State/UserListOverlay.hs view
@@ -31,7 +31,7 @@ import qualified Network.Mattermost.Endpoints as MM import Network.Mattermost.Types -import State ( changeChannel, addUserToCurrentChannel )+import State.Channels ( changeChannel, addUserToCurrentChannel ) import State.Common import Types
+ src/State/Users.hs view
@@ -0,0 +1,47 @@+module State.Users+ (+ handleNewUsers+ , handleTypingUser+ , handleNewUserDirect+ )+where++import Prelude ()+import Prelude.MH++import Data.Time ( getCurrentTime )+import Lens.Micro.Platform++import qualified Network.Mattermost.Endpoints as MM+import Network.Mattermost.Types++import Config+import Types++import State.Common+++handleNewUsers :: Seq UserId -> MH ()+handleNewUsers newUserIds = doAsyncMM Preempt getUserInfo addNewUsers+ where getUserInfo session _ =+ do nUsers <- MM.mmGetUsersByIds newUserIds session+ let usrInfo u = userInfoFromUser u True+ usrList = toList nUsers+ return $ usrInfo <$> usrList++ addNewUsers :: [UserInfo] -> MH ()+ addNewUsers = mapM_ addNewUser++-- | 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)++handleNewUserDirect :: User -> MH ()+handleNewUserDirect newUser = do+ let usrInfo = userInfoFromUser newUser True+ addNewUser usrInfo
src/Types.hs view
@@ -41,13 +41,6 @@ , trimChannelSigil - , LinkChoice(LinkChoice)- , linkUser- , linkURL- , linkTime- , linkName- , linkFileId- , ChannelSelectState(..) , userMatches , channelMatches@@ -78,6 +71,7 @@ , csEditState , csClientConfig , csLastJoinRequest+ , csViewedMessage , timeZone , whenMode , setMode@@ -127,6 +121,7 @@ , crConn , crConfiguration , crSyntaxMap+ , crLogManager , getSession , getResourceSession @@ -147,10 +142,29 @@ , MH , runMHEvent , mh+ , generateUUID+ , generateUUID_IO , mhSuspendAndResume , mhHandleEventLensed , St.gets+ , mhError + , mhLog+ , LogContext(..)+ , withLogContext+ , withLogContextChannelId+ , getLogContext+ , LogMessage(..)+ , LogCommand(..)+ , LogCategory(..)++ , LogManager(..)+ , startLoggingToFile+ , stopLoggingToFile+ , requestLogSnapshot+ , requestLogDestination+ , sendLogMessage+ , requestQuit , clientPostToMessage , getMessageForPostId@@ -186,6 +200,8 @@ , useNickname , displaynameForUserId , raiseInternalEvent+ , getNewMessageCutoff+ , getEditedMessageCutoff , normalChannelSigil @@ -210,16 +226,20 @@ import Brick.BChan import Brick.Widgets.Edit ( Editor, editor ) import Brick.Widgets.List ( List, list )+import Control.Concurrent.Async ( Async ) import Control.Concurrent.MVar ( MVar ) import qualified Control.Concurrent.STM as STM import Control.Exception ( SomeException ) import qualified Control.Monad.State as St+import qualified Control.Monad.Reader as R import qualified Data.Foldable as F import qualified Data.HashMap.Strict as HM import Data.List ( partition, sortBy ) import qualified Data.Sequence as Seq import qualified Data.Set as Set import qualified Data.Text as T+import Data.Time.Clock ( UTCTime, getCurrentTime )+import Data.UUID ( UUID ) import qualified Data.Vector as Vec import Lens.Micro.Platform ( at, makeLenses, lens, (%~), (^?!), (.=) , (%=), (^?), (.~)@@ -227,6 +247,7 @@ import Network.Connection ( HostNotResolved, HostCannotConnect ) import Skylighting.Types ( SyntaxMap ) import System.Exit ( ExitCode )+import System.Random ( randomIO ) import Text.Aspell ( Aspell ) import Network.Mattermost ( ConnectionData )@@ -302,6 +323,9 @@ -- ^ Whether to permit an insecure HTTP connection. , configChannelListWidth :: Int -- ^ The width, in columns, of the channel list sidebar.+ , configLogMaxBufferSize :: Int+ -- ^ The maximum size, in log entries, of the internal log+ -- message buffer. , configShowOlderEdits :: Bool -- ^ Whether to highlight the edit indicator on edits made -- prior to the beginning of the current session.@@ -409,6 +433,7 @@ | MessagePreviewViewport | UserListSearchInput | UserListSearchResults+ | ViewMessageArea deriving (Eq, Show, Ord) -- | The sum type of exceptions we expect to encounter on authentication@@ -444,17 +469,6 @@ | CLId Int deriving (Eq, Show) --- | This type represents links to things in the 'open links' view.-data LinkChoice =- LinkChoice { _linkTime :: ServerTime- , _linkUser :: UserRef- , _linkName :: Text- , _linkURL :: Text- , _linkFileId :: Maybe FileId- } deriving (Eq, Show)--makeLenses ''LinkChoice- -- Sigils normalChannelSigil :: Text normalChannelSigil = "~"@@ -533,6 +547,69 @@ preferenceValue p /= PreferenceValue "false" } | otherwise = u +-- | Log message tags.+data LogCategory =+ LogGeneral+ | LogAPI+ | LogError+ deriving (Eq, Show)++-- | A log message.+data LogMessage =+ LogMessage { logMessageText :: !Text+ -- ^ The text of the log message.+ , logMessageContext :: !(Maybe LogContext)+ -- ^ The optional context information relevant to the log+ -- message.+ , logMessageCategory :: !LogCategory+ -- ^ The category of the log message.+ , logMessageTimestamp :: !UTCTime+ -- ^ The timestamp of the log message.+ }+ deriving (Show)++-- | A logging thread command.+data LogCommand =+ LogToFile FilePath+ -- ^ Start logging to the specified path.+ | LogAMessage !LogMessage+ -- ^ Log the specified message.+ | StopLogging+ -- ^ Stop any active logging.+ | ShutdownLogging+ -- ^ Shut down.+ | GetLogDestination+ -- ^ Ask the logging thread about its active logging destination.+ | LogSnapshot FilePath+ -- ^ Ask the logging thread to dump the current buffer to the+ -- specified destination.+ deriving (Show)++-- | A handle to the log manager thread.+data LogManager =+ LogManager { logManagerCommandChannel :: STM.TChan LogCommand+ , logManagerHandle :: Async ()+ }++startLoggingToFile :: LogManager -> FilePath -> IO ()+startLoggingToFile mgr loc = sendLogCommand mgr $ LogToFile loc++stopLoggingToFile :: LogManager -> IO ()+stopLoggingToFile mgr = sendLogCommand mgr StopLogging++requestLogSnapshot :: LogManager -> FilePath -> IO ()+requestLogSnapshot mgr path = sendLogCommand mgr $ LogSnapshot path++requestLogDestination :: LogManager -> IO ()+requestLogDestination mgr = sendLogCommand mgr GetLogDestination++sendLogMessage :: LogManager -> LogMessage -> IO ()+sendLogMessage mgr lm = sendLogCommand mgr $ LogAMessage lm++sendLogCommand :: LogManager -> LogCommand -> IO ()+sendLogCommand mgr c =+ STM.atomically $ STM.writeTChan (logManagerCommandChannel mgr) c+ -- | 'ChatResources' represents configuration and connection-related -- information, as opposed to current model or view information. -- Information that goes in the 'ChatResources' value should be limited@@ -552,6 +629,7 @@ , _crFlaggedPosts :: Set PostId , _crUserPreferences :: UserPreferences , _crSyntaxMap :: SyntaxMap+ , _crLogManager :: LogManager } @@ -641,6 +719,7 @@ | MessageSelectDeleteConfirm | PostListOverlay PostListContents | UserListOverlay+ | ViewMessage deriving (Eq) -- | We're either connected or we're not.@@ -710,6 +789,9 @@ -- ^ The most recently-joined channel ID that we look for -- in an asynchronous join notification, so that we can -- switch to it in the sidebar.+ , _csViewedMessage :: Maybe Message+ -- ^ Set when the ViewMessage mode is active. The message+ -- being viewed. } -- | Startup state information that is constructed prior to building a@@ -750,6 +832,7 @@ , _csUserListOverlay = nullUserListOverlayState , _csClientConfig = Nothing , _csLastJoinRequest = Nothing+ , _csViewedMessage = Nothing } nullUserListOverlayState :: UserListOverlayState@@ -795,7 +878,7 @@ -- | The state of message selection mode. data MessageSelectState =- MessageSelectState { selectMessagePostId :: Maybe PostId+ MessageSelectState { selectMessageId :: Maybe MessageId } -- | The state of the post list overlay.@@ -828,27 +911,69 @@ -- * MH Monad +-- | Logging context information, in the event that metadata should+-- accompany a log message.+data LogContext =+ LogContext { logContextChannelId :: Maybe ChannelId+ }+ deriving (Eq, Show)+ -- | A value of type 'MH' @a@ represents a computation that can -- manipulate the application state and also request that the -- application quit newtype MH a =- MH { fromMH :: St.StateT (ChatState, ChatState -> EventM Name (Next ChatState)) (EventM Name) a }+ MH { fromMH :: R.ReaderT (Maybe LogContext) (St.StateT (ChatState, ChatState -> EventM Name (Next ChatState)) (EventM Name)) a } +-- | Use a modified logging context for the duration of the specified MH+-- action.+withLogContext :: (Maybe LogContext -> Maybe LogContext) -> MH a -> MH a+withLogContext modifyContext act =+ MH $ R.withReaderT modifyContext (fromMH act)++withLogContextChannelId :: ChannelId -> MH a -> MH a+withLogContextChannelId cId act =+ let f Nothing = Just $ LogContext (Just cId)+ f (Just c) = Just $ c { logContextChannelId = Just cId }+ in withLogContext f act++-- | Get the current logging context.+getLogContext :: MH (Maybe LogContext)+getLogContext = MH R.ask++-- | Log a message.+mhLog :: LogCategory -> Text -> MH ()+mhLog cat msg = do+ ctx <- getLogContext+ now <- liftIO getCurrentTime+ let lm = LogMessage { logMessageText = msg+ , logMessageContext = ctx+ , logMessageCategory = cat+ , logMessageTimestamp = now+ }+ mgr <- use (to (_crLogManager . _csResources))+ liftIO $ sendLogMessage mgr lm+ -- | Run an 'MM' computation, choosing whether to continue or halt based -- on the resulting runMHEvent :: ChatState -> MH () -> EventM Name (Next ChatState) runMHEvent st (MH mote) = do- ((), (st', rs)) <- St.runStateT mote (st, Brick.continue)+ ((), (st', rs)) <- St.runStateT (R.runReaderT mote Nothing) (st, Brick.continue) rs st' -- | lift a computation in 'EventM' into 'MH' mh :: EventM Name a -> MH a-mh = MH . St.lift+mh = MH . R.lift . St.lift +generateUUID :: MH UUID+generateUUID = liftIO generateUUID_IO++generateUUID_IO :: IO UUID+generateUUID_IO = randomIO+ mhHandleEventLensed :: Lens' ChatState b -> (e -> b -> EventM Name b) -> e -> MH () mhHandleEventLensed ln f event = MH $ do (st, b) <- St.get- n <- St.lift $ f event (st ^. ln)+ n <- R.lift $ St.lift $ f event (st ^. ln) St.put (st & ln .~ n , b) mhSuspendAndResume :: (ChatState -> IO ChatState) -> MH ()@@ -910,6 +1035,13 @@ data InternalEvent = DisplayError MHError -- ^ Some kind of application error occurred+ | LoggingStarted FilePath+ | LoggingStopped FilePath+ | LogStartFailed FilePath String+ | LogDestination (Maybe FilePath)+ | LogSnapshotSucceeded FilePath+ | LogSnapshotFailed FilePath String+ -- ^ Logging events from the logging thread -- | Application errors. data MHError =@@ -937,6 +1069,7 @@ -- ^ The specified help topic was not found | AsyncErrEvent SomeException -- ^ For errors that arise in the course of async IO operations+ deriving (Show) -- ** Application State Lenses @@ -1004,6 +1137,12 @@ queue <- use (csResources.crEventQueue) St.liftIO $ writeBChan queue (IEvent ev) +-- | Log and raise an error.+mhError :: MHError -> MH ()+mhError err = do+ mhLog LogError $ T.pack $ show err+ raiseInternalEvent (DisplayError err)+ isMine :: ChatState -> Message -> Bool isMine st msg = (UserI $ myUserId st) == msg^.mUser @@ -1145,6 +1284,7 @@ clientPostToMessage :: ClientPost -> Message clientPostToMessage cp = Message { _mText = cp^.cpText+ , _mMarkdownSource = cp^.cpMarkdownSource , _mUser = case cp^.cpUserOverride of Just n | cp^.cpType == NormalPost -> UserOverride (n <> "[BOT]")@@ -1158,7 +1298,7 @@ case cp^.cpInReplyToPost of Nothing -> NotAReply Just pId -> InReplyTo pId- , _mPostId = Just $ cp^.cpPostId+ , _mMessageId = Just $ MessagePostId $ cp^.cpPostId , _mReactions = cp^.cpReactions , _mOriginalPost = Just $ cp^.cpOriginalPost , _mFlagged = False@@ -1275,3 +1415,13 @@ , hChannelSet = Set.fromList (st^..csChannels.folded.ccInfo.cdName) , hSyntaxMap = st^.csResources.crSyntaxMap }++getNewMessageCutoff :: ChannelId -> ChatState -> Maybe NewMessageIndicator+getNewMessageCutoff cId st = do+ cc <- st^?csChannel(cId)+ return $ cc^.ccInfo.cdNewMessageIndicator++getEditedMessageCutoff :: ChannelId -> ChatState -> Maybe ServerTime+getEditedMessageCutoff cId st = do+ cc <- st^?csChannel(cId)+ cc^.ccInfo.cdEditedMessageThreshold
src/Types/KeyEvents.hs view
@@ -77,8 +77,10 @@ -- E.g. Pressing enter on an item in a list to do something with it | ActivateListItemEvent + | ViewMessageEvent | FlagMessageEvent | YankMessageEvent+ | YankWholeMessageEvent | DeleteMessageEvent | EditMessageEvent | ReplyMessageEvent@@ -126,7 +128,9 @@ , SearchSelectDownEvent , FlagMessageEvent+ , ViewMessageEvent , YankMessageEvent+ , YankWholeMessageEvent , DeleteMessageEvent , EditMessageEvent , ReplyMessageEvent@@ -307,7 +311,9 @@ ActivateListItemEvent -> "activate-list-item" FlagMessageEvent -> "flag-message"+ ViewMessageEvent -> "view-message" YankMessageEvent -> "yank-message"+ YankWholeMessageEvent -> "yank-whole-message" DeleteMessageEvent -> "delete-message" EditMessageEvent -> "edit-message" ReplyMessageEvent -> "reply-message"
src/Types/Messages.hs view
@@ -1,6 +1,8 @@ {-# LANGUAGE MultiParamTypeClasses #-} {-# LANGUAGE FlexibleInstances #-} {-# LANGUAGE TemplateHaskell #-}+{-# LANGUAGE DeriveGeneric #-}+{-# LANGUAGE DeriveAnyClass #-} {-| @@ -29,8 +31,8 @@ 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+user-posted messages (@case mMessageId of Just _@ or @case mType of CP+_@), but others will include client-generated messages (@case mMessageId of Nothing@ or @case mType of C _@). --}@@ -38,11 +40,15 @@ module Types.Messages ( -- * Message and operations on a single Message Message(..)- , isDeletable, isReplyable, isEditable, isReplyTo, isGap+ , isDeletable, isReplyable, isEditable, isReplyTo, isGap, isFlaggable , mText, mUser, mDate, mType, mPending, mDeleted- , mAttachments, mInReplyToMsg, mPostId, mReactions, mFlagged- , mOriginalPost, mChannelId+ , mAttachments, mInReplyToMsg, mMessageId, mReactions, mFlagged+ , mOriginalPost, mChannelId, mMarkdownSource , MessageType(..)+ , MessageId(..)+ , isPostMessage+ , messagePostId+ , messageIdPostId , UserRef(..) , ReplyState(..) , clientMessageToMessage@@ -61,15 +67,27 @@ , splitMessagesOn , splitRetrogradeMessagesOn , findMessage+ , getNextMessageId+ , getPrevMessageId , getNextPostId , getPrevPostId , getEarliestPostMsg , getLatestPostMsg+ , getLatestSelectableMessage , findLatestUserMessage -- * Operations on any Message type , messagesAfter , removeMatchesFromSubset , withFirstMessage+ , msgURLs+ , altInlinesString++ , LinkChoice(LinkChoice)+ , linkUser+ , linkURL+ , linkTime+ , linkName+ , linkFileId ) where @@ -77,13 +95,18 @@ import Prelude.MH import Cheapskate ( Blocks )+import qualified Cheapskate as C+import qualified Data.Foldable as F+import Data.Hashable ( Hashable ) import qualified Data.Map.Strict as Map import Data.Sequence as Seq import Data.Tuple+import Data.UUID ( UUID )+import GHC.Generics ( Generic ) import Lens.Micro.Platform ( makeLenses ) import Network.Mattermost.Types ( ChannelId, PostId, Post- , ServerTime, UserId )+ , ServerTime, UserId, FileId ) import Types.DirectionalSeq import Types.Posts@@ -92,10 +115,19 @@ -- ---------------------------------------------------------------------- -- * Messages +data MessageId = MessagePostId PostId+ | MessageUUID UUID+ deriving (Eq, Read, Show, Generic, Hashable)++messageIdPostId :: MessageId -> Maybe PostId+messageIdPostId (MessagePostId p) = Just p+messageIdPostId _ = Nothing+ -- | A 'Message' is any message we might want to render, either from -- Mattermost itself or from a client-internal source. data Message = Message { _mText :: Blocks+ , _mMarkdownSource :: Text , _mUser :: UserRef , _mDate :: ServerTime , _mType :: MessageType@@ -103,21 +135,39 @@ , _mDeleted :: Bool , _mAttachments :: Seq Attachment , _mInReplyToMsg :: ReplyState- , _mPostId :: Maybe PostId+ , _mMessageId :: Maybe MessageId , _mReactions :: Map.Map Text Int , _mOriginalPost :: Maybe Post , _mFlagged :: Bool , _mChannelId :: Maybe ChannelId } deriving (Show) +isPostMessage :: Message -> Bool+isPostMessage m =+ isJust (_mMessageId m >>= messageIdPostId)++messagePostId :: Message -> Maybe PostId+messagePostId m = do+ mId <- _mMessageId m+ messageIdPostId mId+ isDeletable :: Message -> Bool-isDeletable m = _mType m `elem` [CP NormalPost, CP Emote]+isDeletable m =+ isJust (messagePostId m) &&+ _mType m `elem` [CP NormalPost, CP Emote] +isFlaggable :: Message -> Bool+isFlaggable = isJust . messagePostId+ isReplyable :: Message -> Bool-isReplyable m = _mType m `elem` [CP NormalPost, CP Emote]+isReplyable m =+ isJust (messagePostId m) &&+ (_mType m `elem` [CP NormalPost, CP Emote]) isEditable :: Message -> Bool-isEditable m = _mType m `elem` [CP NormalPost, CP Emote]+isEditable m =+ isJust (messagePostId m) &&+ _mType m `elem` [CP NormalPost, CP Emote] isReplyTo :: PostId -> Message -> Bool isReplyTo expectedParentId m =@@ -149,6 +199,17 @@ | InReplyTo PostId deriving (Show) +-- | This type represents links to things in the 'open links' view.+data LinkChoice =+ LinkChoice { _linkTime :: ServerTime+ , _linkUser :: UserRef+ , _linkName :: Text+ , _linkURL :: Text+ , _linkFileId :: Maybe FileId+ } deriving (Eq, Show)++makeLenses ''LinkChoice+ -- | 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@@ -156,6 +217,7 @@ clientMessageToMessage :: ClientMessage -> Message clientMessageToMessage cm = Message { _mText = getBlocks (cm^.cmText)+ , _mMarkdownSource = cm^.cmText , _mUser = NoUser , _mDate = cm^.cmDate , _mType = C $ cm^.cmType@@ -163,7 +225,7 @@ , _mDeleted = False , _mAttachments = Seq.empty , _mInReplyToMsg = NotAReply- , _mPostId = Nothing+ , _mMessageId = Nothing , _mReactions = Map.empty , _mOriginalPost = Nothing , _mFlagged = False@@ -173,6 +235,7 @@ newMessageOfType :: Text -> MessageType -> ServerTime -> Message newMessageOfType text typ d = Message { _mText = getBlocks text+ , _mMarkdownSource = text , _mUser = NoUser , _mDate = d , _mType = typ@@ -180,7 +243,7 @@ , _mDeleted = False , _mAttachments = Seq.empty , _mInReplyToMsg = NotAReply- , _mPostId = Nothing+ , _mMessageId = Nothing , _mReactions = Map.empty , _mOriginalPost = Nothing , _mFlagged = False@@ -231,7 +294,7 @@ _ :> l -> case compare (m^.mDate) (l^.mDate) of GT -> DSeq $ dseq ml |> m- EQ -> if m^.mPostId == l^.mPostId && isJust (m^.mPostId)+ EQ -> if m^.mMessageId == l^.mMessageId && isJust (m^.mMessageId) then ml else dirDateInsert m ml LT -> dirDateInsert m ml@@ -244,7 +307,7 @@ insAfter c (Just n, l) = case compare (n^.mDate) (c^.mDate) of GT -> (Nothing, c <| (n <| l))- EQ -> if n^.mPostId == c^.mPostId && isJust (c^.mPostId)+ EQ -> if n^.mMessageId == c^.mMessageId && isJust (c^.mMessageId) then (Nothing, c <| l) else (Just n, c <| l) LT -> (Just n, c <| l)@@ -297,39 +360,68 @@ -- ---------------------------------------------------------------------- -- * 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+-- | Searches for the specified MessageId and returns a tuple where the+-- first element is the Message associated with the MessageId (if it -- exists), and the second element is another tuple: the first element -- of the second is all the messages from the beginning of the list to--- the message just before the PostId message (or all messages if not+-- the message just before the MessageId message (or all messages if not -- found) *in reverse order*, and the second element of the second are -- all the messages that follow the found message (none if the message -- was never found) in *forward* order.-splitMessages :: Maybe PostId+splitMessages :: Maybe MessageId -> Messages -> (Maybe Message, (RetrogradeMessages, Messages))-splitMessages pid msgs = splitMessagesOn (\m -> isJust pid && m^.mPostId == pid) msgs+splitMessages mid msgs = splitMessagesOn (\m -> isJust mid && m^.mMessageId == mid) msgs -- | findMessage searches for a specific message as identified by the -- PostId. The search starts from the most recent messages because -- that is the most likely place the message will occur.-findMessage :: PostId -> Messages -> Maybe Message-findMessage pid msgs =- findIndexR (\m -> m^.mPostId == Just pid) (dseq msgs)+findMessage :: MessageId -> Messages -> Maybe Message+findMessage mid msgs =+ findIndexR (\m -> m^.mMessageId == Just mid) (dseq msgs) >>= Just . Seq.index (dseq msgs) --- | Look forward for the first Message that corresponds to a user--- Post (i.e. has a post ID) that follows the specified PostId+-- | Look forward for the first Message with an ID that follows the+-- specified PostId+getNextMessageId :: Maybe MessageId -> Messages -> Maybe MessageId+getNextMessageId = getRelMessageId foldl++-- | Look backwards for the first Message with an ID that comes before+-- the specified MessageId.+getPrevMessageId :: Maybe MessageId -> Messages -> Maybe MessageId+getPrevMessageId = getRelMessageId $ foldr . flip++-- | Look forward for the first Message with an ID that follows the+-- specified PostId getNextPostId :: Maybe PostId -> Messages -> Maybe PostId getNextPostId = getRelPostId foldl --- | Look backwards for the first Message that corresponds to a user--- Post (i.e. has a post ID) that comes before the specified PostId.+-- | Look backwards for the first Post with an ID that comes before+-- the specified PostId. getPrevPostId :: Maybe PostId -> Messages -> Maybe PostId getPrevPostId = getRelPostId $ foldr . flip --- | Find the next PostId after the specified PostId (if there is one)--- by folding in the specified direction+-- | Find the next MessageId after the specified MessageId (if there is+-- one) by folding in the specified direction+getRelMessageId :: ((Either MessageId (Maybe MessageId)+ -> Message+ -> Either MessageId (Maybe MessageId))+ -> Either MessageId (Maybe MessageId)+ -> Messages+ -> Either MessageId (Maybe MessageId))+ -> Maybe MessageId+ -> Messages+ -> Maybe MessageId+getRelMessageId folD jp = case jp of+ Nothing -> \msgs -> (getLatestPostMsg msgs >>= _mMessageId)+ Just p -> either (const Nothing) id . folD fnd (Left p)+ where fnd = either fndp fndnext+ fndp c v = if v^.mMessageId == Just c then Right Nothing else Left c+ idOfPost m = if m^.mDeleted then Nothing else m^.mMessageId+ fndnext n m = Right (n <|> idOfPost m)++-- | Find the next PostId after the specified PostId (if there is+-- one) by folding in the specified direction getRelPostId :: ((Either PostId (Maybe PostId) -> Message -> Either PostId (Maybe PostId))@@ -340,11 +432,20 @@ -> Messages -> Maybe PostId getRelPostId folD jp = case jp of- Nothing -> \msgs -> (getLatestPostMsg msgs >>= _mPostId)+ Nothing -> \msgs -> do+ latest <- getLatestPostMsg msgs+ mId <- latest^.mMessageId+ case mId of+ MessagePostId pId -> return pId+ _ -> Nothing Just p -> either (const Nothing) id . folD fnd (Left p) where fnd = either fndp fndnext- fndp c v = if v^.mPostId == Just c then Right Nothing else Left c- idOfPost m = if m^.mDeleted then Nothing else m^.mPostId+ fndp c v = if v^.mMessageId == Just (MessagePostId c) then Right Nothing else Left c+ idOfPost m = if m^.mDeleted+ then Nothing+ else case m^.mMessageId of+ Just (MessagePostId pId) -> Just pId+ _ -> Nothing fndnext n m = Right (n <|> idOfPost m) -- | Find the most recent message that is a Post (as opposed to a@@ -355,7 +456,14 @@ EmptyR -> Nothing _ :> m -> Just m +-- | Find the most recent message that is a message with an ID.+getLatestSelectableMessage :: Messages -> Maybe Message+getLatestSelectableMessage msgs =+ case viewr $ dropWhileR (not . validSelectableMessage) (dseq msgs) of+ EmptyR -> Nothing+ _ :> m -> Just m + -- | Find the earliest message that is a Post (as opposed to a -- local message) (if any). getEarliestPostMsg :: Messages -> Maybe Message@@ -375,10 +483,15 @@ EmptyR -> Nothing _ :> m -> Just m - validUserMessage :: Message -> Bool-validUserMessage m = isJust (m^.mPostId) && not (m^.mDeleted)+validUserMessage m =+ not (m^.mDeleted) && case m^.mMessageId of+ Just (MessagePostId _) -> True+ _ -> False +validSelectableMessage :: Message -> Bool+validSelectableMessage m = isJust $ m^.mMessageId+ -- ---------------------------------------------------------------------- -- * Operations on any Message type @@ -388,7 +501,7 @@ -- | Removes any Messages (all types) for which the predicate is true -- from the specified subset of messages (identified by a starting and--- ending PostId, inclusive) and returns the resulting list (from+-- ending MessageId, inclusive) and returns the resulting list (from -- start to finish, irrespective of 'firstId' and 'lastId') and the -- list of removed items. --@@ -406,21 +519,21 @@ -- -- @removeMatchesFromSubset matchPred fromId toId msgs = (remaining, removed)@ ---removeMatchesFromSubset :: (Message -> Bool) -> Maybe PostId -> Maybe PostId+removeMatchesFromSubset :: (Message -> Bool) -> Maybe MessageId -> Maybe MessageId -> Messages -> (Messages, Messages) removeMatchesFromSubset matching firstId lastId msgs =- let knownIds = fmap (^.mPostId) msgs+ let knownIds = fmap (^.mMessageId) msgs in if isNothing firstId && isNothing lastId then swap $ dirSeqPartition matching msgs else if isJust firstId && firstId `elem` knownIds then onDirSeqSubset- (\m -> m^.mPostId == firstId)- (if isJust lastId then \m -> m^.mPostId == lastId else const False)+ (\m -> m^.mMessageId == firstId)+ (if isJust lastId then \m -> m^.mMessageId == lastId else const False) (swap . dirSeqPartition matching) msgs else if isJust lastId && lastId `elem` knownIds then onDirSeqSubset (const True)- (\m -> m^.mPostId == lastId)+ (\m -> m^.mMessageId == lastId) (swap . dirSeqPartition matching) msgs else (msgs, noMessages) @@ -429,3 +542,53 @@ -- Note that the message is not necessarily a posted user message. withFirstMessage :: SeqDirection dir => (Message -> r) -> DirectionalSeq dir Message -> Maybe r withFirstMessage = withDirSeqHead++msgURLs :: Message -> Seq LinkChoice+msgURLs msg+ | NoUser <- msg^.mUser = mempty+ | otherwise =+ let uid = msg^.mUser+ msgUrls = (\ (url, text) -> LinkChoice (msg^.mDate) uid text url Nothing) <$>+ (mconcat $ blockGetURLs <$> (toList $ msg^.mText))+ attachmentURLs = (\ a ->+ LinkChoice+ (msg^.mDate)+ uid+ ("attachment `" <> (a^.attachmentName) <> "`")+ (a^.attachmentURL)+ (Just (a^.attachmentFileId)))+ <$> (msg^.mAttachments)+ in msgUrls <> attachmentURLs++blockGetURLs :: C.Block -> Seq.Seq (Text, Text)+blockGetURLs (C.Para is) = mconcat $ inlineGetURLs <$> toList is+blockGetURLs (C.Header _ is) = mconcat $ inlineGetURLs <$> toList is+blockGetURLs (C.Blockquote bs) = mconcat $ blockGetURLs <$> toList bs+blockGetURLs (C.List _ _ bss) = mconcat $ mconcat $ (blockGetURLs <$>) <$> (toList <$> bss)+blockGetURLs _ = mempty++inlineGetURLs :: C.Inline -> Seq.Seq (Text, Text)+inlineGetURLs (C.Emph is) = mconcat $ inlineGetURLs <$> toList is+inlineGetURLs (C.Strong is) = mconcat $ inlineGetURLs <$> toList is+inlineGetURLs (C.Link is url "") = (url, inlinesText is) Seq.<| (mconcat $ inlineGetURLs <$> toList is)+inlineGetURLs (C.Link is _ url) = (url, inlinesText is) Seq.<| (mconcat $ inlineGetURLs <$> toList is)+inlineGetURLs (C.Image is url _) = Seq.singleton (url, inlinesText is)+inlineGetURLs _ = mempty++inlinesText :: Seq C.Inline -> Text+inlinesText = F.fold . fmap go+ where go (C.Str t) = t+ go C.Space = " "+ go C.SoftBreak = " "+ go C.LineBreak = " "+ go (C.Emph is) = F.fold (fmap go is)+ go (C.Strong is) = F.fold (fmap go is)+ go (C.Code t) = t+ go (C.Link is _ _) = F.fold (fmap go is)+ go (C.Image is _ _) = "[image" <> altInlinesString is <> "]"+ go (C.Entity t) = t+ go (C.RawHtml t) = t++altInlinesString :: Seq C.Inline -> Text+altInlinesString is | Seq.null is = ""+ | otherwise = ":" <> inlinesText is
src/Types/Posts.hs view
@@ -20,6 +20,7 @@ , ClientPost , toClientPost , cpUserOverride+ , cpMarkdownSource , cpUser , cpText , cpType@@ -105,6 +106,7 @@ -- removed and some preprocessing done. data ClientPost = ClientPost { _cpText :: Blocks+ , _cpMarkdownSource :: Text , _cpUser :: Maybe UserId , _cpUserOverride :: Maybe Text , _cpDate :: ServerTime@@ -187,22 +189,23 @@ -- | Convert a Mattermost 'Post' to a 'ClientPost', passing in a -- 'ParentId' if it has a known one. toClientPost :: Post -> Maybe PostId -> ClientPost-toClientPost p parentId = ClientPost- { _cpText = (getBlocks $ unEmote (postClientPostType p) $ sanitizeUserText $ postMessage p)- <> getAttachmentText p- , _cpUser = postUserId p- , _cpUserOverride = p^.postPropsL.postPropsOverrideUsernameL- , _cpDate = postCreateAt p- , _cpType = postClientPostType p- , _cpPending = False- , _cpDeleted = False- , _cpAttachments = Seq.empty- , _cpInReplyToPost = parentId- , _cpPostId = p^.postIdL- , _cpChannelId = p^.postChannelIdL- , _cpReactions = Map.empty- , _cpOriginalPost = p- }+toClientPost p parentId =+ let src = unEmote (postClientPostType p) $ sanitizeUserText $ postMessage p+ in ClientPost { _cpText = getBlocks src <> getAttachmentText p+ , _cpMarkdownSource = src+ , _cpUser = postUserId p+ , _cpUserOverride = p^.postPropsL.postPropsOverrideUsernameL+ , _cpDate = postCreateAt p+ , _cpType = postClientPostType p+ , _cpPending = False+ , _cpDeleted = False+ , _cpAttachments = Seq.empty+ , _cpInReplyToPost = parentId+ , _cpPostId = p^.postIdL+ , _cpChannelId = p^.postChannelIdL+ , _cpReactions = Map.empty+ , _cpOriginalPost = p+ } -- | Right now, instead of treating 'attachment' properties specially, we're -- just going to roll them directly into the message text
+ src/Util.hs view
@@ -0,0 +1,25 @@+module Util+ ( nubOn+ )+where++import Prelude ()+import Prelude.MH++import qualified Data.Set as Set+++-- | The 'nubOn' function removes duplicate elements from a list. In+-- particular, it keeps only the /last/ occurrence of each+-- element. The equality of two elements in a call to @nub f@ is+-- determined using @f x == f y@, and the resulting elements must have+-- an 'Ord' instance in order to make this function more efficient.+nubOn :: (Ord b) => (a -> b) -> [a] -> [a]+nubOn f = snd . go Set.empty+ where go before [] = (before, [])+ go before (x:xs) =+ let (before', xs') = go before xs+ key = f x in+ if key `Set.member` before'+ then (before', xs')+ else (Set.insert key before', x : xs')
test/Message_QCA.hs view
@@ -4,7 +4,11 @@ module Message_QCA where import Cheapskate_QCA+import Control.Monad (replicateM) import Data.Map hiding (foldr)+import Data.Maybe (fromMaybe)+import Data.UUID (UUID, fromByteString)+import qualified Data.ByteString.Lazy as BSL import Network.Mattermost.QuickCheck import Network.Mattermost.Types import Test.Tasty.QuickCheck@@ -23,6 +27,7 @@ genMessage :: Gen Message genMessage = Message <$> genBlocks+ <*> genText <*> genUserRef <*> genTime <*> genMessageType@@ -30,12 +35,16 @@ <*> arbitrary <*> genSeq genAttachment <*> genReplyState- <*> genMaybe genPostId+ <*> (fmap MessagePostId <$> genMaybe genPostId) <*> genMap genText arbitrary <*> genMaybe genPost <*> arbitrary <*> (Just <$> genChannelId) +genUUID :: Gen UUID+genUUID = (fromMaybe (error "BUG: invalid genUUID result") . fromByteString . BSL.pack) <$>+ replicateM 16 arbitrary+ -- Some tests specifically want deleted or non-deleted messages, so -- make an easy way to specify these. newtype Message__DeletedPost = Message__DeletedPost { delMsg :: Message }@@ -44,7 +53,8 @@ genMessage__DeletedPost :: Gen Message__DeletedPost genMessage__DeletedPost = Message__DeletedPost <$> (Message- <$> genBlocks+ <$> genBlocks+ <*> genText <*> genUserRef <*> genTime <*> genMessageType@@ -52,7 +62,7 @@ <*> return True -- mDeleted <*> genSeq genAttachment <*> genReplyState- <*> (Just <$> genPostId) -- must have been Posted if deleted+ <*> (Just <$> MessagePostId <$> genPostId) -- must have been Posted if deleted <*> genMap genText arbitrary <*> genMaybe genPost <*> arbitrary@@ -64,7 +74,8 @@ genMessage__Posted :: Gen Message__Posted genMessage__Posted = Message__Posted <$> (Message- <$> genBlocks+ <$> genBlocks+ <*> genText <*> genUserRef <*> genTime <*> genMessageType@@ -72,7 +83,7 @@ <*> return False -- mDeleted <*> genSeq genAttachment <*> genReplyState- <*> (Just <$> genPostId)+ <*> (Just <$> MessagePostId <$> genPostId) <*> genMap genText arbitrary <*> genMaybe genPost <*> arbitrary@@ -115,6 +126,9 @@ instance Arbitrary Message__DeletedPost where arbitrary = genMessage__DeletedPost instance Arbitrary Message__Posted where arbitrary = genMessage__Posted instance Arbitrary PostId where arbitrary = genPostId+instance Arbitrary MessageId where arbitrary = oneof [ MessagePostId <$> genPostId+ , MessageUUID <$> genUUID+ ] instance Arbitrary Messages where arbitrary = sized $ \s -> foldr addMessage noMessages <$> vectorOf s arbitrary
test/test_messages.hs view
@@ -52,11 +52,11 @@ test_m2 :: IO Message test_m2 = do t2 <- ServerTime <$> getCurrentTime- return $ (makeMsg t2 (Just $ fromId $ Id "m2")) { _mType = CP Emote }+ return $ (makeMsg t2 (Just $ MessagePostId $ fromId $ Id "m2")) { _mType = CP Emote } test_m3 :: IO Message test_m3 = do t3 <- ServerTime <$> getCurrentTime- return $ makeMsg t3 (Just $ fromId $ Id "m3")+ return $ makeMsg t3 (Just $ MessagePostId $ fromId $ Id "m3") setDateOrderMessages :: [Message] -> [Message] setDateOrderMessages = snd . foldl setTimeAndInsert (startTime, [])@@ -65,22 +65,22 @@ 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 NoUser t (CP NormalPost) False False Seq.empty NotAReply- pId Map.empty Nothing False Nothing+makeMsg :: ServerTime -> Maybe MessageId -> Message+makeMsg t mId = Message Seq.empty mempty NoUser t (CP NormalPost) False False Seq.empty NotAReply+ mId Map.empty Nothing False Nothing makeMsgs :: [Message] -> Messages makeMsgs = foldr addMessage noMessages -idlist :: Foldable t => t Message -> [Maybe PostId]-idlist = foldr (\m s -> m^.mPostId : s) []+idlist :: Foldable t => t Message -> [Maybe MessageId]+idlist = foldr (\m s -> m^.mMessageId : s) [] postids :: (Foldable t) => String -> t Message -> String postids names msgs = let zipf = (\(n,z) m -> if null n then ("", ('?', m) : z) else (init n, (last n, m) : z)) zipped = snd $ foldr (flip zipf) (names, []) msgs- pid (n, m) = show n <> ".mPostID=" <> show (m^.mPostId)+ pid (n, m) = show n <> ".mPostID=" <> show (m^.mMessageId) in intercalate ", " $ map pid zipped uniqueIds :: Foldable t => t Message -> Bool@@ -215,7 +215,7 @@ [w', x', y', z'] = l l' = [x', z', w', y'] ex = sortBy (\a b -> compare (a^.mDate) (b^.mDate))- ([e | e <- l', isNothing (e^.mPostId) ] <> l)+ ([e | e <- l', isNothing (messagePostId e) ] <> l) in idlist ex === idlist (makeMsgs $ l' <> l) , testProperty "duplicate dates different IDs in posted order"@@ -261,12 +261,12 @@ moveDownTestSingle :: TestTree moveDownTestSingle = testProperty "Move up from single message" $ \x -> let msgs = addMessage x noMessages- in Nothing == (getNextPostId (x^.mPostId) msgs)+ in Nothing == (getNextPostId (messagePostId x) msgs) moveUpTestSingle :: TestTree moveUpTestSingle = testProperty "Move down from single message" $ \x -> let msgs = addMessage x noMessages- in Nothing == (getPrevPostId (x^.mPostId) msgs)+ in Nothing == (getPrevPostId (messagePostId x) msgs) moveDownTestMultipleStart :: TestTree moveDownTestMultipleStart =@@ -278,12 +278,12 @@ , postMsg z' ] msgs = makeMsgs [x, y, z]- msgid = getNextPostId (x^.mPostId) msgs+ msgid = getNextMessageId (x^.mMessageId) msgs -- for useful info on failure: idents = postids "xyz" msgs info = idents <> " against " <> show msgid in counterexample info $- y^.mPostId == msgid+ y^.mMessageId == msgid moveUpTestMultipleStart :: TestTree moveUpTestMultipleStart =@@ -292,7 +292,7 @@ let [x, y, z] = setDateOrderMessages [ postMsg x', postMsg y', postMsg z'] msgs = makeMsgs [x, y, z]- msgid = getPrevPostId (x^.mPostId) msgs+ msgid = getPrevPostId (messagePostId x) msgs -- for useful info on failure: idents = postids "xyz" msgs info = idents <> " against " <> show msgid@@ -306,7 +306,7 @@ let [x, y, z] = setDateOrderMessages [ postMsg x', postMsg y', postMsg z'] msgs = makeMsgs [x, y, z]- msgid = getNextPostId (z^.mPostId) msgs+ msgid = getNextPostId (messagePostId z) msgs -- for useful info on failure: idents = postids "xyz" msgs info = idents <> " against " <> show msgid@@ -320,12 +320,12 @@ let [x, y, z] = setDateOrderMessages [ postMsg x', postMsg y', postMsg z'] msgs = makeMsgs [x, y, z]- msgid = getPrevPostId (z^.mPostId) msgs+ msgid = getPrevPostId (messagePostId z) msgs -- for useful info on failure: idents = postids "xyz" msgs info = idents <> " against " <> show msgid in uniqueIds msgs ==>- counterexample info $ (y^.mPostId) == msgid+ counterexample info $ (messagePostId y) == msgid moveDownTestMultipleSkipDeleted :: TestTree moveDownTestMultipleSkipDeleted =@@ -337,11 +337,11 @@ , delMsg y' , postMsg z'] msgs = makeMsgs [w, x, y, z]- msgid = getNextPostId (w^.mPostId) msgs+ msgid = getNextPostId (messagePostId w) msgs -- for useful info on failure: idents = postids "wxyz" msgs info = idents <> " against " <> show msgid- in counterexample info $ (z^.mPostId) == msgid+ in counterexample info $ (messagePostId z) == msgid moveUpTestMultipleSkipDeleted :: TestTree moveUpTestMultipleSkipDeleted =@@ -353,12 +353,12 @@ , delMsg y' , postMsg z'] msgs = makeMsgs [w, x, y, z]- msgid = getPrevPostId (z^.mPostId) msgs+ msgid = getPrevPostId (messagePostId z) msgs -- for useful info on failure: idents = postids "wxyz" msgs info = idents <> " against " <> show msgid in uniqueIds msgs ==>- counterexample info $ (w^.mPostId) == msgid+ counterexample info $ (messagePostId w) == msgid moveDownTestMultipleSkipDeletedAll :: TestTree moveDownTestMultipleSkipDeletedAll =@@ -373,7 +373,7 @@ , delMsg y' , delMsg z'] msgs = makeMsgs [w, x, y, z]- msgid = getNextPostId (w^.mPostId) msgs+ msgid = getNextPostId (messagePostId w) msgs -- for useful info on failure: idents = postids "wxyz" msgs info = idents <> " against " <> show msgid@@ -392,7 +392,7 @@ , delMsg y' , delMsg z'] msgs = makeMsgs [w, x, y, z]- msgid = getPrevPostId (z^.mPostId) msgs+ msgid = getPrevPostId (messagePostId z) msgs -- for useful info on failure: idents = postids "wxyz" msgs info = idents <> " against " <> show msgid@@ -406,8 +406,8 @@ in idlist l === idlist rr , testProperty "getLatestMessage finds same in either dir" $ \l -> let rr = unreverseMessages (reverseMessages l) -- KWQ: just one reverse, not two- in ((^.mPostId) <$> getLatestPostMsg l) ===- ((^.mPostId) <$> getLatestPostMsg rr)+ in (messagePostId <$> getLatestPostMsg l) ===+ (messagePostId <$> getLatestPostMsg rr) , testCase "reverse nothing" $ (null $ unreverseMessages $ reverseMessages noMessages) @? "reverse of empty Messages"@@ -421,10 +421,10 @@ [ testProperty "getEarliestPostMsg" $ \(m1, m2, m3, m4, m5) -> let mlist = m1 : m2 : m3 : m4 : m5 : [] msgs = makeMsgs mlist- postIds = fmap (^.mPostId)+ postIds = fmap messagePostId $ sortBy (compare `on` (^.mDate))- $ filter (\m -> isJust (m^.mPostId) && (not $ m^.mDeleted)) mlist- firstPostId = (^.mPostId) <$> getEarliestPostMsg msgs+ $ filter (\m -> isJust (messagePostId m) && (not $ m^.mDeleted)) mlist+ firstPostId = messagePostId <$> getEarliestPostMsg msgs in if null postIds then Nothing === firstPostId else Just (head postIds) === firstPostId@@ -432,10 +432,10 @@ , testProperty "getLatestPostMsg" $ \(m1, m2, m3, m4, m5) -> let mlist = m1 : m2 : m3 : m4 : m5 : [] msgs = makeMsgs mlist- postIds = fmap (^.mPostId)+ postIds = fmap messagePostId $ sortBy (compare `on` (^.mDate))- $ filter (\m -> isJust (m^.mPostId) && (not $ m^.mDeleted)) mlist- lastPostId = (^.mPostId) <$> getLatestPostMsg msgs+ $ filter (\m -> isJust (messagePostId m) && (not $ m^.mDeleted)) mlist+ lastPostId = messagePostId <$> getLatestPostMsg msgs in counterexample ("ids: " <> show (idlist msgs) <> "\n dates: " <> (show $ fmap show $ foldr (\m l -> m^.mDate : l) [] msgs) <> "\n deleted: " <> (show $ fmap show $ foldr (\m l -> m^.mDeleted : l) [] msgs)@@ -447,11 +447,11 @@ , testProperty "findLatestUserMessage" $ \(m1, m2, m3, m4, m5) -> let mlist = m1 : m2 : m3 : m4 : m5 : [] msgs = makeMsgs mlist- postIds = fmap (^.mPostId)+ postIds = fmap messagePostId $ sortBy (compare `on` (^.mDate))- $ filter (\m -> isJust (m^.mPostId) && (not $ m^.mDeleted)) mlist- lastPostId = (^.mPostId) <$> findLatestUserMessage (const True) msgs- firstPostId = (^.mPostId) <$> findLatestUserMessage (\m -> m^.mPostId == head postIds) msgs+ $ filter (\m -> isJust (messagePostId m) && (not $ m^.mDeleted)) mlist+ lastPostId = messagePostId <$> findLatestUserMessage (const True) msgs+ firstPostId = messagePostId <$> findLatestUserMessage (\m -> messagePostId m == head postIds) msgs in counterexample ("ids: " <> show (idlist msgs) <> "\n dates: " <> (show $ fmap show $ foldr (\m l -> m^.mDate : l) [] msgs) <> "\n deleted: " <> (show $ fmap show $ foldr (\m l -> m^.mDeleted : l) [] msgs)@@ -476,11 +476,11 @@ in isNothing m , testProperty "split nothing on not found" $ \(w', x', y', z') ->- let (m, _) = splitMessages (w^.mPostId) msgs+ let (m, _) = splitMessages (w^.mMessageId) msgs [w, x, y, z] = setDateOrderMessages [w', x', y', z'] msgs = makeMsgs [x, y, z] idents = postids "wxyz" msgs- info = idents <> " against " <> show ((fromJust m)^.mPostId)+ info = idents <> " against " <> show (messagePostId (fromJust m)) in uniqueIds [w, x, y, z] ==> counterexample info $ isNothing m @@ -496,7 +496,7 @@ , testProperty "all before reversed on not found" $ \(w', x', y', z') ->- let (_, (before, _)) = splitMessages (w^.mPostId) msgs+ let (_, (before, _)) = splitMessages (w^.mMessageId) msgs msgs = makeMsgs inpl inpl = [x, y, z] [w, x, y, z] = setDateOrderMessages [w', x', y', z']@@ -505,16 +505,16 @@ , testProperty "found at first position" $ \(w', x', y', z') ->- let (m, _) = splitMessages (w^.mPostId) msgs+ let (m, _) = splitMessages (w^.mMessageId) msgs msgs = makeMsgs inpl inpl = [w, x, y, z] [w, x, y, z] = setDateOrderMessages [w', x', y', z'] in validIds inpl && uniqueIds inpl ==>- w^.mPostId == (fromJust m)^.mPostId+ messagePostId w == messagePostId (fromJust m) , testProperty "no before when found at first position" $ \(w', x', y', z') ->- let (_, (before, _)) = splitMessages (w^.mPostId) msgs+ let (_, (before, _)) = splitMessages (w^.mMessageId) msgs msgs = makeMsgs inpl inpl = [w, x, y, z] [w, x, y, z] = setDateOrderMessages [w', x', y', z']@@ -523,7 +523,7 @@ counterexample info $ null $ unreverseMessages before , testProperty "remaining after when found at first position" $ \(w', x', y', z') ->- let (_, (_, after)) = splitMessages (w^.mPostId) msgs+ let (_, (_, after)) = splitMessages (w^.mMessageId) msgs msgs = makeMsgs inpl inpl = [w, x, y, z] [w, x, y, z] = setDateOrderMessages [w', x', y', z']@@ -534,16 +534,16 @@ , testProperty "found at last position" $ \(w', x', y', z') ->- let (m, _) = splitMessages (z^.mPostId) msgs+ let (m, _) = splitMessages (z^.mMessageId) msgs msgs = makeMsgs inpl inpl = [w, x, y, z] [w, x, y, z] = setDateOrderMessages [w', x', y', z'] in validIds inpl && uniqueIds inpl ==>- z^.mPostId == (fromJust m)^.mPostId+ messagePostId z == messagePostId (fromJust m) , testProperty "reversed before when found at last position" $ \(w', x', y', z') ->- let (_, (before, _)) = splitMessages (z^.mPostId) msgs+ let (_, (before, _)) = splitMessages (z^.mMessageId) msgs msgs = makeMsgs inpl inpl = [w, x, y, z] [w, x, y, z] = setDateOrderMessages [w', x', y', z']@@ -554,7 +554,7 @@ , testProperty "no after when found at last position" $ \(w', x', y', z') ->- let (_, (_, after)) = splitMessages (z^.mPostId) msgs+ let (_, (_, after)) = splitMessages (z^.mMessageId) msgs msgs = makeMsgs inpl inpl = [w, x, y, z] [w, x, y, z] = setDateOrderMessages [w', x', y', z']@@ -564,17 +564,17 @@ , testProperty "found at midpoint position" $ \(v', w', x', y', z') ->- let (m, _) = splitMessages (x^.mPostId) msgs+ let (m, _) = splitMessages (x^.mMessageId) msgs msgs = makeMsgs inpl inpl = [v, w, x, y, z] [v, w, x, y, z] = setDateOrderMessages [v', w', x', y', z'] in validIds inpl && uniqueIds inpl ==>- x^.mPostId == (fromJust m)^.mPostId+ messagePostId x == messagePostId (fromJust m) , testProperty "reversed before when found at midpoint position" $ \(v', w', x', y', z') ->- let (_, (before, _)) = splitMessages (x^.mPostId) msgs+ let (_, (before, _)) = splitMessages (x^.mMessageId) msgs msgs = makeMsgs inpl inpl = [v, w, x, y, z] [v, w, x, y, z] = setDateOrderMessages@@ -586,7 +586,7 @@ , testProperty "after when found at midpoint position" $ \(v', w', x', y', z') ->- let (_, (_, after)) = splitMessages (x^.mPostId) msgs+ let (_, (_, after)) = splitMessages (x^.mMessageId) msgs msgs = makeMsgs inpl inpl = [v, w, x, y, z] [v, w, x, y, z] = setDateOrderMessages@@ -642,8 +642,8 @@ , testCase "remove only as last" $ let (remaining, removed) = removeMatchesFromSubset (const True) (Just id1) (Just id2) msgs- id1 = fromId $ Id "id1"- id2 = fromId $ Id "id2"+ id1 = MessagePostId $ fromId $ Id "id1"+ id2 = MessagePostId $ fromId $ Id "id2" msgs = makeMsgs [makeMsg (ServerTime originTime) (Just id2)] in null remaining && length removed == 1 @? "removed" @@ -651,7 +651,8 @@ let msgs = makeMsgs $ msg : msglist ids = idlist msgs id2 = ids !! idx2'- id1 = PI $ Id $ T.intercalate "-" $ map (unId . unPI) $ catMaybes ids+ id1 = MessagePostId $ PI $ Id $ T.intercalate "-" $ map (unId . unPI) $+ catMaybes ((\i -> i >>= messageIdPostId) <$> ids) idx2' = abs idx2 `mod` length ids (remaining, removed) = removeMatchesFromSubset (const True) (Just id1) id2 msgs in (isJust id2) && uniqueIds msgs ==>@@ -730,7 +731,7 @@ idx1' = head idxl idx2' = last idxl - (remaining, removed) = removeMatchesFromSubset (\m -> m^.mPostId == id1) id1 id2 msgs+ (remaining, removed) = removeMatchesFromSubset (\m -> m^.mMessageId == id1) id1 id2 msgs in uniqueIds msgs && isJust id1 && isJust id2 ==> counterexample ("with idlist " <> show (idlist msgs) <> "\n idx1=" <> show idx1' <>@@ -755,7 +756,7 @@ idx1' = head idxl idx2' = last idxl - (remaining, removed) = removeMatchesFromSubset (\m -> m^.mPostId == id2) id1 id2 msgs+ (remaining, removed) = removeMatchesFromSubset (\m -> m^.mMessageId == id2) id1 id2 msgs in uniqueIds msgs && isJust id1 && isJust id2 ==> counterexample ("with idlist " <> show (idlist msgs) <> "\n idx1=" <> show idx1' <>@@ -782,7 +783,7 @@ rmvIds = map snd $ filter (odd . fst) $ zip [(0::Int)..] matchIds - (remaining, removed) = removeMatchesFromSubset (\m -> m^.mPostId `elem` rmvIds) id1 id2 msgs+ (remaining, removed) = removeMatchesFromSubset (\m -> m^.mMessageId `elem` rmvIds) id1 id2 msgs in uniqueIds msgs && isJust id1 && isJust id2 ==> counterexample ("with idlist " <> show (idlist msgs) <> "\n idx1=" <> show idx1' <>@@ -898,3 +899,8 @@ instance EqProp PostId where a =-= b = (show $ idString a) =-= (show $ idString b)++instance EqProp MessageId where+ (MessagePostId a) =-= (MessagePostId b) = (show $ idString a) =-= (show $ idString b)+ (MessageUUID a) =-= (MessageUUID b) = (show a) =-= (show b)+ _ =-= _ = eq True False