diff --git a/CHANGELOG.md b/CHANGELOG.md --- a/CHANGELOG.md +++ b/CHANGELOG.md @@ -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 `: start logging to the specified file. + * `/log-stop`: stop any active logging. + * `/log-snapshot `: 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 ========= diff --git a/PRACTICES.md b/PRACTICES.md --- a/PRACTICES.md +++ b/PRACTICES.md @@ -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 diff --git a/matterhorn.cabal b/matterhorn.cabal --- a/matterhorn.cabal +++ b/matterhorn.cabal @@ -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 diff --git a/src/App.hs b/src/App.hs --- a/src/App.hs +++ b/src/App.hs @@ -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 diff --git a/src/Clipboard.hs b/src/Clipboard.hs new file mode 100644 --- /dev/null +++ b/src/Clipboard.hs @@ -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 () diff --git a/src/Command.hs b/src/Command.hs --- a/src/Command.hs +++ b/src/Command.hs @@ -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 diff --git a/src/Config.hs b/src/Config.hs --- a/src/Config.hs +++ b/src/Config.hs @@ -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 diff --git a/src/Constants.hs b/src/Constants.hs --- a/src/Constants.hs +++ b/src/Constants.hs @@ -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 diff --git a/src/Draw.hs b/src/Draw.hs --- a/src/Draw.hs +++ b/src/Draw.hs @@ -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 diff --git a/src/Draw/ChannelList.hs b/src/Draw/ChannelList.hs --- a/src/Draw/ChannelList.hs +++ b/src/Draw/ChannelList.hs @@ -30,7 +30,7 @@ import Lens.Micro.Platform (Getting, at, non) import Draw.Util -import State +import State.Channels import Themes import Types diff --git a/src/Draw/Main.hs b/src/Draw/Main.hs --- a/src/Draw/Main.hs +++ b/src/Draw/Main.hs @@ -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 = diff --git a/src/Draw/Messages.hs b/src/Draw/Messages.hs --- a/src/Draw/Messages.hs +++ b/src/Draw/Messages.hs @@ -1,4 +1,10 @@ -module Draw.Messages where +module Draw.Messages + ( nameForUserRef + , maxMessageHeight + , renderSingleMessage + , unsafeRenderMessageSelection + ) +where import Brick import Brick.Widgets.Border diff --git a/src/Draw/PostListOverlay.hs b/src/Draw/PostListOverlay.hs --- a/src/Draw/PostListOverlay.hs +++ b/src/Draw/PostListOverlay.hs @@ -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 -> diff --git a/src/Draw/ShowHelp.hs b/src/Draw/ShowHelp.hs --- a/src/Draw/ShowHelp.hs +++ b/src/Draw/ShowHelp.hs @@ -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 diff --git a/src/Draw/ViewMessage.hs b/src/Draw/ViewMessage.hs new file mode 100644 --- /dev/null +++ b/src/Draw/ViewMessage.hs @@ -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 diff --git a/src/Events.hs b/src/Events.hs --- a/src/Events.hs +++ b/src/Events.hs @@ -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) diff --git a/src/Events/ChannelScroll.hs b/src/Events/ChannelScroll.hs --- a/src/Events/ChannelScroll.hs +++ b/src/Events/ChannelScroll.hs @@ -7,7 +7,8 @@ import qualified Graphics.Vty as Vty import Events.Keybindings -import State +import State.ChannelScroll +import State.UrlSelect import Types diff --git a/src/Events/ChannelSelect.hs b/src/Events/ChannelSelect.hs --- a/src/Events/ChannelSelect.hs +++ b/src/Events/ChannelSelect.hs @@ -8,7 +8,8 @@ import Lens.Micro.Platform ( (%=) ) import Events.Keybindings -import State +import State.Channels +import State.ChannelSelect import Types diff --git a/src/Events/DeleteChannelConfirm.hs b/src/Events/DeleteChannelConfirm.hs --- a/src/Events/DeleteChannelConfirm.hs +++ b/src/Events/DeleteChannelConfirm.hs @@ -6,7 +6,7 @@ import qualified Graphics.Vty as Vty import Types -import State +import State.Channels onEventDeleteChannelConfirm :: Vty.Event -> MH () diff --git a/src/Events/JoinChannel.hs b/src/Events/JoinChannel.hs --- a/src/Events/JoinChannel.hs +++ b/src/Events/JoinChannel.hs @@ -9,7 +9,7 @@ import Network.Mattermost.Types ( getId ) -import State ( joinChannel ) +import State.Channels ( joinChannel ) import Types diff --git a/src/Events/Keybindings.hs b/src/Events/Keybindings.hs --- a/src/Events/Keybindings.hs +++ b/src/Events/Keybindings.hs @@ -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' ] diff --git a/src/Events/LeaveChannelConfirm.hs b/src/Events/LeaveChannelConfirm.hs --- a/src/Events/LeaveChannelConfirm.hs +++ b/src/Events/LeaveChannelConfirm.hs @@ -5,7 +5,7 @@ import qualified Graphics.Vty as Vty -import State +import State.Channels import Types diff --git a/src/Events/Main.hs b/src/Events/Main.hs --- a/src/Events/Main.hs +++ b/src/Events/Main.hs @@ -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 diff --git a/src/Events/MessageSelect.hs b/src/Events/MessageSelect.hs --- a/src/Events/MessageSelect.hs +++ b/src/Events/MessageSelect.hs @@ -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 ] diff --git a/src/Events/ShowHelp.hs b/src/Events/ShowHelp.hs --- a/src/Events/ShowHelp.hs +++ b/src/Events/ShowHelp.hs @@ -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" diff --git a/src/Events/UrlSelect.hs b/src/Events/UrlSelect.hs --- a/src/Events/UrlSelect.hs +++ b/src/Events/UrlSelect.hs @@ -7,7 +7,7 @@ import qualified Graphics.Vty as Vty import Events.Keybindings -import State +import State.UrlSelect import Types diff --git a/src/Events/ViewMessage.hs b/src/Events/ViewMessage.hs new file mode 100644 --- /dev/null +++ b/src/Events/ViewMessage.hs @@ -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 + ] diff --git a/src/Markdown.hs b/src/Markdown.hs --- a/src/Markdown.hs +++ b/src/Markdown.hs @@ -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 diff --git a/src/Prelude/MH.hs b/src/Prelude/MH.hs --- a/src/Prelude/MH.hs +++ b/src/Prelude/MH.hs @@ -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 diff --git a/src/Scripts.hs b/src/Scripts.hs --- a/src/Scripts.hs +++ b/src/Scripts.hs @@ -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 diff --git a/src/State.hs b/src/State.hs deleted file mode 100644 --- a/src/State.hs +++ /dev/null @@ -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) diff --git a/src/State/Async.hs b/src/State/Async.hs new file mode 100644 --- /dev/null +++ b/src/State/Async.hs @@ -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 () diff --git a/src/State/ChannelScroll.hs b/src/State/ChannelScroll.hs new file mode 100644 --- /dev/null +++ b/src/State/ChannelScroll.hs @@ -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 diff --git a/src/State/ChannelSelect.hs b/src/State/ChannelSelect.hs new file mode 100644 --- /dev/null +++ b/src/State/ChannelSelect.hs @@ -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 diff --git a/src/State/Channels.hs b/src/State/Channels.hs new file mode 100644 --- /dev/null +++ b/src/State/Channels.hs @@ -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." diff --git a/src/State/Common.hs b/src/State/Common.hs --- a/src/State/Common.hs +++ b/src/State/Common.hs @@ -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 <> "*" diff --git a/src/State/Editing.hs b/src/State/Editing.hs --- a/src/State/Editing.hs +++ b/src/State/Editing.hs @@ -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 diff --git a/src/State/Flagging.hs b/src/State/Flagging.hs new file mode 100644 --- /dev/null +++ b/src/State/Flagging.hs @@ -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 () diff --git a/src/State/Help.hs b/src/State/Help.hs new file mode 100644 --- /dev/null +++ b/src/State/Help.hs @@ -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 diff --git a/src/State/Logging.hs b/src/State/Logging.hs new file mode 100644 --- /dev/null +++ b/src/State/Logging.hs @@ -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 diff --git a/src/State/MessageSelect.hs b/src/State/MessageSelect.hs new file mode 100644 --- /dev/null +++ b/src/State/MessageSelect.hs @@ -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 () diff --git a/src/State/Messages.hs b/src/State/Messages.hs --- a/src/State/Messages.hs +++ b/src/State/Messages.hs @@ -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 diff --git a/src/State/PostListOverlay.hs b/src/State/PostListOverlay.hs --- a/src/State/PostListOverlay.hs +++ b/src/State/PostListOverlay.hs @@ -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 diff --git a/src/State/Reactions.hs b/src/State/Reactions.hs new file mode 100644 --- /dev/null +++ b/src/State/Reactions.hs @@ -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 diff --git a/src/State/Setup.hs b/src/State/Setup.hs --- a/src/State/Setup.hs +++ b/src/State/Setup.hs @@ -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 diff --git a/src/State/Setup/Threads.hs b/src/State/Setup/Threads.hs --- a/src/State/Setup/Threads.hs +++ b/src/State/Setup/Threads.hs @@ -1,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 diff --git a/src/State/Setup/Threads/Logging.hs b/src/State/Setup/Threads/Logging.hs new file mode 100644 --- /dev/null +++ b/src/State/Setup/Threads/Logging.hs @@ -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 diff --git a/src/State/Themes.hs b/src/State/Themes.hs new file mode 100644 --- /dev/null +++ b/src/State/Themes.hs @@ -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) + diff --git a/src/State/UrlSelect.hs b/src/State/UrlSelect.hs new file mode 100644 --- /dev/null +++ b/src/State/UrlSelect.hs @@ -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)) diff --git a/src/State/UserListOverlay.hs b/src/State/UserListOverlay.hs --- a/src/State/UserListOverlay.hs +++ b/src/State/UserListOverlay.hs @@ -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 diff --git a/src/State/Users.hs b/src/State/Users.hs new file mode 100644 --- /dev/null +++ b/src/State/Users.hs @@ -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 diff --git a/src/Types.hs b/src/Types.hs --- a/src/Types.hs +++ b/src/Types.hs @@ -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 diff --git a/src/Types/KeyEvents.hs b/src/Types/KeyEvents.hs --- a/src/Types/KeyEvents.hs +++ b/src/Types/KeyEvents.hs @@ -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" diff --git a/src/Types/Messages.hs b/src/Types/Messages.hs --- a/src/Types/Messages.hs +++ b/src/Types/Messages.hs @@ -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 diff --git a/src/Types/Posts.hs b/src/Types/Posts.hs --- a/src/Types/Posts.hs +++ b/src/Types/Posts.hs @@ -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 diff --git a/src/Util.hs b/src/Util.hs new file mode 100644 --- /dev/null +++ b/src/Util.hs @@ -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') diff --git a/test/Message_QCA.hs b/test/Message_QCA.hs --- a/test/Message_QCA.hs +++ b/test/Message_QCA.hs @@ -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 diff --git a/test/test_messages.hs b/test/test_messages.hs --- a/test/test_messages.hs +++ b/test/test_messages.hs @@ -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