diff --git a/CHANGELOG.md b/CHANGELOG.md --- a/CHANGELOG.md +++ b/CHANGELOG.md @@ -1,4 +1,20 @@ +40600.1.0 +========= + +Performance improvements: + * Matterhorn's reconnection handling was improved to more reliably + fetch messages that arrived while the client was disconnected. + * Startup performance was improved by reducing redundant post and user + metadata fetches when loading channel messages. + +Other fixes: + * The multi-line toggle help message now shows the active binding. + * Slash commands now support multi-line input. Previously only the + first line was passed as the command input. + * Matterhorn now updates channel view status on updates from other + clients (#342) + 40600.0.0 ========= diff --git a/README.md b/README.md --- a/README.md +++ b/README.md @@ -75,7 +75,9 @@ (indicated with a `M-` prefix). If your keyboard has an `Alt` key, that will work as `Meta`. If it does not, you may be able to configure your terminal to provide `Meta` via other means (e.g. iTerm2 on OS X can be -configured to make the left Option key work as Meta). +configured to make the left Option key work as Meta). Keybindings can +be customized in the configuration file; see `/help keybindings` for +details. To join a channel, use the `/join` command to choose from a list of available channels. To create a channel, use `/create-channel`. To leave @@ -143,6 +145,7 @@ * Preview message rendering before sending * Optional smart quoting for efficient Markdown entry * Edit messages with `$EDITOR` +* Rebindable keys (see `/help keybindings`) * Message editor with kill/yank buffer and readline-style keybindings * Tab-completion of usernames, channel names, and commands * Spell-checking via Aspell diff --git a/matterhorn.cabal b/matterhorn.cabal --- a/matterhorn.cabal +++ b/matterhorn.cabal @@ -1,5 +1,5 @@ name: matterhorn -version: 40600.0.0 +version: 40600.1.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 @@ -37,6 +37,7 @@ State State.Common State.Editing + State.Messages State.PostListOverlay State.Setup State.Setup.Threads @@ -87,7 +88,7 @@ ScopedTypeVariables ghc-options: -Wall -threaded build-depends: base >=4.8 && <5 - , mattermost-api == 40600.0.0 + , mattermost-api == 40600.1.0 , base-compat >= 0.9 && < 0.10 , unordered-containers >= 0.2 && < 0.3 , containers >= 0.5.7 && < 0.6 @@ -99,7 +100,8 @@ , config-ini >= 0.1.2 && < 0.2 , process >= 1.4 && < 1.7 , microlens-platform >= 0.3 && < 0.4 - , brick >= 0.32 && < 0.33 + , brick >= 0.34 && < 0.35 + , brick-skylighting >= 0.1 && < 0.2 , vty >= 5.19 && < 5.20 , word-wrap >= 0.4.0 && < 0.5 , transformers >= 0.4 && < 0.6 @@ -120,7 +122,7 @@ , aspell-pipe >= 0.3 && < 0.4 , stm-delay >= 0.1 && < 0.2 , unix >= 2.7.1.0 && < 2.7.3.0 - , skylighting >= 0.3.3.1 && < 0.4 + , skylighting >= 0.6 && < 0.7 , timezone-olson >= 0.1.7 && < 0.2 , timezone-series >= 0.1.6.1 && < 0.2 , aeson >= 1.2.3.0 && < 1.3 @@ -132,6 +134,7 @@ main-is: test_messages.hs other-modules: Cheapskate_QCA , Message_QCA + , TimeUtils , Types.Messages , Types.Posts , Types.DirectionalSeq @@ -142,7 +145,7 @@ hs-source-dirs: src, test build-depends: base >=4.7 && <5 , base-compat >= 0.9 && < 0.10 - , brick >= 0.32 && < 0.33 + , brick >= 0.34 && < 0.35 , bytestring >= 0.10 && < 0.11 , cheapskate >= 0.1 && < 0.2 , checkers >= 0.4 && < 0.5 @@ -153,8 +156,8 @@ , filepath >= 1.4 && < 1.5 , hashable >= 1.2 && < 1.3 , Hclip >= 3.0 && < 3.1 - , mattermost-api == 40600.0.0 - , mattermost-api-qc == 40600.0.0 + , mattermost-api == 40600.1.0 + , mattermost-api-qc == 40600.1.0 , microlens-platform >= 0.3 && < 0.4 , mtl >= 2.2 && < 2.3 , process >= 1.4 && < 1.7 @@ -164,7 +167,7 @@ , string-conversions >= 0.4 && < 0.5 , tasty >= 0.11 && < 0.12 , tasty-hunit >= 0.9 && < 0.10 - , tasty-quickcheck >= 0.8 && < 0.9 + , tasty-quickcheck >= 0.8 && < 0.10 , text >= 1.2 && < 1.3 , text-zipper >= 0.10 && < 0.11 , time >= 1.6 && < 1.9 diff --git a/src/Command.hs b/src/Command.hs --- a/src/Command.hs +++ b/src/Command.hs @@ -9,6 +9,7 @@ import qualified Control.Exception as Exn import Control.Monad.IO.Class (liftIO) import Control.Monad (void) +import qualified Data.Char as Char import Data.Monoid ((<>)) import qualified Data.Text as T import Lens.Micro.Platform @@ -24,20 +25,38 @@ import HelpTopics import Scripts +-- | This function skips any initial whitespace and returns the first +-- 'token' (i.e. any sequence of non-whitespace characters) as well as +-- the trailing rest of the string, after any whitespace. This is used +-- for tokenizing the first bits of command input while leaving the +-- subsequent chunks unchanged, preserving newlines and other +-- important formatting. +unwordHead :: T.Text -> Maybe (T.Text, T.Text) +unwordHead t = + let t' = T.dropWhile Char.isSpace t + (w, rs) = T.break Char.isSpace t' + in if T.null w + then Nothing + else Just (w, T.dropWhile Char.isSpace rs) + printArgSpec :: CmdArgs a -> T.Text printArgSpec NoArg = "" printArgSpec (LineArg ts) = "[" <> ts <> "]" printArgSpec (TokenArg t NoArg) = "[" <> t <> "]" printArgSpec (TokenArg t rs) = "[" <> t <> "] " <> printArgSpec rs -matchArgs :: CmdArgs a -> [T.Text] -> Either T.Text a -matchArgs NoArg [] = return () -matchArgs NoArg [t] = Left ("unexpected argument '" <> t <> "'") -matchArgs NoArg ts = Left ("unexpected arguments '" <> T.unwords ts <> "'") -matchArgs (LineArg _) ts = return (T.unwords ts) -matchArgs rs@(TokenArg _ NoArg) [] = Left ("missing argument: " <> printArgSpec rs) -matchArgs rs@(TokenArg _ _) [] = Left ("missing arguments: " <> printArgSpec rs) -matchArgs (TokenArg _ rs) (t:ts) = (,) <$> pure t <*> matchArgs rs ts +matchArgs :: CmdArgs a -> T.Text -> Either T.Text a +matchArgs NoArg t = case unwordHead t of + Nothing -> return () + Just (a, as) + | not (T.all Char.isSpace as) -> Left ("Unexpected arguments '" <> t <> "'") + | otherwise -> Left ("Unexpected argument '" <> a <> "'") +matchArgs (LineArg _) t = return t +matchArgs spec@(TokenArg _ rs) t = case unwordHead t of + Nothing -> case rs of + NoArg -> Left ("Missing argument: " <> printArgSpec spec) + _ -> Left ("Missing arguments: " <> printArgSpec spec) + Just (a, as) -> (,) <$> pure a <*> matchArgs rs as commandList :: [Cmd] commandList = @@ -89,13 +108,17 @@ knownTopics = (" - " <>) <$> helpTopicName <$> helpTopics postErrorMessage msg Just topic -> showHelpScreen topic + , Cmd "sh" "List the available shell scripts" NoArg $ \ () -> listScripts + , Cmd "group-msg" "Create a group chat" (LineArg "user1 user2 ...") createGroupChannel + , Cmd "sh" "Run a prewritten shell script" (TokenArg "script" (LineArg "message")) $ \ (script, text) -> findAndRunScript script text + , Cmd "me" "Send an emote message" (LineArg "message") $ \msg -> execMMCommand "me" msg @@ -155,12 +178,14 @@ dispatchCommand :: T.Text -> MH () dispatchCommand cmd = - case T.words cmd of - (x:xs) | matchingCmds <- [ c | c@(Cmd name _ _ _) <- commandList - , name == x - ] -> go [] matchingCmds + case unwordHead cmd of + Just (x, xs) + | matchingCmds <- [ c + | c@(Cmd name _ _ _) <- commandList + , name == x + ] -> go [] matchingCmds where go [] [] = do - execMMCommand x (T.unwords xs) + execMMCommand x xs go errs [] = do let msg = ("error running command /" <> x <> ":\n" <> mconcat [ " " <> e | e <- errs ]) diff --git a/src/Draw.hs b/src/Draw.hs --- a/src/Draw.hs +++ b/src/Draw.hs @@ -3,7 +3,6 @@ module Draw (draw) where import Brick -import Lens.Micro.Platform ((^.)) import Types import Draw.Main @@ -15,7 +14,7 @@ draw :: ChatState -> [Widget Name] draw st = - case st^.csMode of + case appMode st of Main -> drawMain st ChannelScroll -> drawMain st UrlSelect -> drawMain st diff --git a/src/Draw/ChannelList.hs b/src/Draw/ChannelList.hs --- a/src/Draw/ChannelList.hs +++ b/src/Draw/ChannelList.hs @@ -84,7 +84,7 @@ -- some channel selection text. hasActiveChannelSelection :: ChatState -> Bool hasActiveChannelSelection st = - st^.csMode == ChannelSelect && not (T.null (st^.csChannelSelectState.channelSelectInput)) + appMode st == ChannelSelect && not (T.null (st^.csChannelSelectState.channelSelectInput)) -- | This is the main function that is called from external code to -- render the ChannelList sidebar. diff --git a/src/Draw/JoinChannel.hs b/src/Draw/JoinChannel.hs --- a/src/Draw/JoinChannel.hs +++ b/src/Draw/JoinChannel.hs @@ -50,7 +50,6 @@ renderJoinListItem :: Bool -> Channel -> Widget Name renderJoinListItem _ chan = let baseStr = chan^.channelNameL <> " (" <> chan^.channelDisplayNameL <> ")" - s = baseStr <> "\n " <> (T.strip $ chan^.channelPurposeL) - in vLimit 2 $ - txtWrapWith (defaultWrapSettings { preserveIndentation = True }) s <+> - (fill ' ') + s = " " <> (T.strip $ chan^.channelPurposeL) + in (vLimit 1 $ padRight Max $ txt baseStr) <=> + (vLimit 1 $ txtWrapWith (defaultWrapSettings { preserveIndentation = True }) s) diff --git a/src/Draw/Main.hs b/src/Draw/Main.hs --- a/src/Draw/Main.hs +++ b/src/Draw/Main.hs @@ -28,7 +28,7 @@ import Data.Char (isSpace, isPunctuation) import Lens.Micro.Platform -import Network.Mattermost.Types (ChannelId, Type(Direct), ServerTime(..)) +import Network.Mattermost.Types (ChannelId, Type(Direct), ServerTime(..), UserId) import Network.Mattermost.Lenses import qualified Graphics.Vty as Vty @@ -42,10 +42,9 @@ import TimeUtils (justAfter, justBefore) import Types import Types.Channels ( NewMessageIndicator(..) - , ChannelState(..) , ClientChannel , ccInfo, ccContents - , cdCurrentState, cdTypingUsers + , cdTypingUsers , cdName, cdType, cdHeader, cdMessages , findChannelById) import Types.Messages @@ -55,9 +54,9 @@ import Events.Keybindings import Events.MessageSelect -previewFromInput :: T.Text -> T.Text -> Maybe Message +previewFromInput :: UserId -> T.Text -> Maybe Message previewFromInput _ s | s == T.singleton cursorSentinel = Nothing -previewFromInput uname s = +previewFromInput uId s = -- If it starts with a slash but not /me, this has no preview -- representation let isCommand = "/" `T.isPrefixOf` s @@ -69,7 +68,7 @@ in if isCommand && not isEmote then Nothing else Just $ Message { _mText = getBlocks content - , _mUserName = Just uname + , _mUser = UserI uId , _mDate = ServerTime $ UTCTime (fromGregorian 1970 1 1) 0 -- The date is not used for preview -- rendering, but we need to provide one. @@ -243,7 +242,9 @@ st^.csEditState.cedEditor.editContentsL) <> "/" <> (show $ length curContents) <> "]" , hBorderWithLabel $ withDefAttr clientEmphAttr $ - str "In multi-line mode. Press M-e to finish." + txt $ "In multi-line mode. Press " <> + (ppBinding (getFirstDefaultBinding ToggleMultiLineEvent)) <> + " to finish." ] replyDisplay = case st^.csEditState.cedEditMode of @@ -252,7 +253,9 @@ in hBox [ replyArrow , addEllipsis $ renderMessage MessageData { mdMessage = msgWithoutParent + , mdUserName = msgWithoutParent^.mUser.to (nameForUserRef st) , mdParentMessage = Nothing + , mdParentUserName = Nothing , mdHighlightSet = hs , mdEditThreshold = Nothing , mdShowOlderEdits = False @@ -329,11 +332,8 @@ messages = padTop Max $ padRight (Pad 1) body body = chatText - <=> case chan^.ccInfo.cdCurrentState.to stateMessage of - Nothing -> emptyWidget - Just msg -> withDefAttr clientMessageAttr $ txt msg - chatText = case st^.csMode of + chatText = case appMode st of ChannelScroll -> -- n.b., In this mode, the output is cached and scrolled -- via the viewport. This means that newly received @@ -406,14 +406,6 @@ cId = st^.csCurrentChannelId chan = st^.csCurrentChannel --- | When displaying channel contents, it may be convenient to display --- information about the current state of the channel. -stateMessage :: ChannelState -> Maybe T.Text -stateMessage ChanGettingInfo = Just "[Fetching channel information...]" -stateMessage ChanUnloaded = Just "[Channel content pending...]" -stateMessage ChanGettingPosts = Just "[Fetching channel content...]" -stateMessage ChanInitialSelect = Just "[channel initial content pending...]" -stateMessage ChanLoaded = Nothing getMessageListing :: ChannelId -> ChatState -> Messages getMessageListing cId st = @@ -537,7 +529,7 @@ inputPreview st hs | not $ st^.csShowMessagePreview = emptyWidget | otherwise = thePreview where - uname = st^.csMe.userUsernameL + uId = st^.csMe.userIdL -- Insert a cursor sentinel into the input text just before -- rendering the preview. We use the inserted sentinel (which is -- not rendered) to get brick to ensure that the line the cursor is @@ -550,28 +542,30 @@ curContents = getText $ (gotoEOL >>> insertChar cursorSentinel) $ st^.csEditState.cedEditor.editContentsL curStr = T.intercalate "\n" curContents - previewMsg = previewFromInput uname curStr + previewMsg = previewFromInput uId curStr thePreview = let noPreview = str "(No preview)" msgPreview = case previewMsg of Nothing -> noPreview Just pm -> if T.null curStr then noPreview - else renderMessage MessageData - { mdMessage = pm - , mdParentMessage = - getParentMessage st pm - , mdHighlightSet = hs - , mdEditThreshold = Nothing - , mdShowOlderEdits = False - , mdRenderReplyParent = True - , mdIndentBlocks = True - } + else prview pm $ getParentMessage st pm + prview m p = renderMessage MessageData + { mdMessage = m + , mdUserName = m^.mUser.to (nameForUserRef st) + , mdParentMessage = p + , mdParentUserName = p >>= (^.mUser.to (nameForUserRef st)) + , mdHighlightSet = hs + , mdEditThreshold = Nothing + , mdShowOlderEdits = False + , mdRenderReplyParent = True + , mdIndentBlocks = True + } in (maybePreviewViewport msgPreview) <=> hBorderWithLabel (withDefAttr clientEmphAttr $ str "[Preview ↑]") userInputArea :: ChatState -> HighlightSet -> Widget Name userInputArea st hs = - case st^.csMode of + case appMode st of ChannelSelect -> renderChannelSelect st UrlSelect -> hCenter $ hBox [ txt "Press " , withDefAttr clientEmphAttr $ txt "Enter" @@ -600,11 +594,11 @@ where hs = getHighlightSet st channelListWidth = configChannelListWidth $ st^.csResources.crConfiguration - mainDisplay = case st^.csMode of + mainDisplay = case appMode st of UrlSelect -> renderUrlList st _ -> maybeSubdue $ renderCurrentChannelDisplay st hs - bottomBorder = case st^.csMode of + bottomBorder = case appMode st of MessageSelect -> messageSelectBottomBar st _ -> case st^.csEditState.cedCurrentCompletion of Just _ | length (st^.csEditState.cedCompletionAlternatives) > 1 -> completionAlternatives st @@ -630,7 +624,7 @@ Just Nothing -> hLimit 2 hBorder <+> txt "*" Nothing -> emptyWidget - maybeSubdue = if st^.csMode == ChannelSelect + maybeSubdue = if appMode st == ChannelSelect then forceAttr "" else id @@ -652,7 +646,7 @@ let time = link^.linkTime in attr sel $ vLimit 2 $ (vLimit 1 $ - hBox [ let u = (link^.linkUser) in colorUsername u u + hBox [ let u = maybe "" id (link^.linkUser.to (nameForUserRef st)) in colorUsername u u , if link^.linkName == link^.linkURL then emptyWidget else (txt ": " <+> (renderText $ link^.linkName)) diff --git a/src/Draw/Messages.hs b/src/Draw/Messages.hs --- a/src/Draw/Messages.hs +++ b/src/Draw/Messages.hs @@ -24,6 +24,15 @@ maxMessageHeight :: Int maxMessageHeight = 200 + +-- | nameForUserRef converts the UserRef into a printable name, based +-- on the current known user data. +nameForUserRef :: ChatState -> UserRef -> Maybe T.Text +nameForUserRef st uref = case uref of + NoUser -> Nothing + UserOverride t -> Just t + UserI uId -> getUsernameForUserId st uId + -- | renderSingleMessage is the main message drawing function. -- -- The `ind` argument specifies an "indicator boundary". Showing @@ -41,7 +50,9 @@ InReplyTo pId -> getMessageForPostId st pId m = renderMessage MessageData { mdMessage = msg + , mdUserName = msg^.mUser.to (nameForUserRef st) , mdParentMessage = parent + , mdParentUserName = parent >>= (^.mUser.to (nameForUserRef st)) , mdEditThreshold = ind , mdHighlightSet = hs , mdShowOlderEdits = showOlderEdits @@ -63,17 +74,17 @@ reacMsg = Map.foldMapWithKey renderR (msg^.mReactions) in Just $ withDefAttr emojiAttr $ txt (" " <> reacMsg) msgTxt = - case msg^.mUserName of - Just _ - | msg^.mType == CP Join || msg^.mType == CP Leave -> - withDefAttr clientMessageAttr m - | otherwise -> m - Nothing -> + case msg^.mUser of + NoUser -> case msg^.mType of C DateTransition -> withDefAttr dateTransitionAttr (hBorderWithLabel m) C NewMessagesTransition -> withDefAttr newMessageTransitionAttr (hBorderWithLabel m) C Error -> withDefAttr errorMessageAttr m + C UnknownGap -> withDefAttr gapMessageAttr m _ -> withDefAttr clientMessageAttr m + _ | msg^.mType == CP Join || msg^.mType == CP Leave -> + withDefAttr clientMessageAttr m + | otherwise -> m fullMsg = vBox $ msgTxt : catMaybes [msgAtch, msgReac] maybeRenderTime w = hBox [renderTimeFunc (msg^.mDate), txt " ", w] maybeRenderTimeWith f = case msg^.mType of diff --git a/src/Draw/ShowHelp.hs b/src/Draw/ShowHelp.hs --- a/src/Draw/ShowHelp.hs +++ b/src/Draw/ShowHelp.hs @@ -183,8 +183,8 @@ , "values, are as follows:" ] ] - nextChanBinding = ppBinding (head (defaultBindings NextChannelEvent)) - prevChanBinding = ppBinding (head (defaultBindings PrevChannelEvent)) + nextChanBinding = ppBinding (getFirstDefaultBinding NextChannelEvent) + prevChanBinding = ppBinding (getFirstDefaultBinding PrevChannelEvent) validKeys = map (padTop (Pad 1) . renderText . mconcat) [ [ "The syntax used for key sequences consists of zero or more " , "single-character modifier characters followed by a keystroke " diff --git a/src/Events.hs b/src/Events.hs --- a/src/Events.hs +++ b/src/Events.hs @@ -10,6 +10,7 @@ import Data.List (intercalate) import qualified Data.Map as M import qualified Data.Set as Set +import qualified Data.Sequence as Seq import qualified Data.Text as T import Data.Monoid ((<>)) import GHC.Exts (groupWith) @@ -39,18 +40,20 @@ import Events.PostListOverlay onEvent :: ChatState -> BrickEvent Name MHEvent -> EventM Name (Next ChatState) -onEvent st ev = runMHEvent st $ case ev of - (AppEvent e) -> onAppEvent e - (VtyEvent (Vty.EvKey (Vty.KChar 'l') [Vty.MCtrl])) -> do - vty <- mh getVtyHandle - liftIO $ Vty.refresh vty - (VtyEvent e) -> onVtyEvent e - _ -> return () +onEvent st ev = runMHEvent st (onEv >> fetchVisibleIfNeeded) + where onEv = do case ev of + (AppEvent e) -> onAppEvent e + (VtyEvent (Vty.EvKey (Vty.KChar 'l') [Vty.MCtrl])) -> do + vty <- mh getVtyHandle + liftIO $ Vty.refresh vty + (VtyEvent e) -> onVtyEvent e + _ -> return () onAppEvent :: MHEvent -> MH () onAppEvent RefreshWebsocketEvent = connectWebsockets -onAppEvent WebsocketDisconnect = +onAppEvent WebsocketDisconnect = do csConnectionStatus .= Disconnected + disconnectChannels onAppEvent WebsocketConnect = do csConnectionStatus .= Connected refreshChannelsAndUsers @@ -81,7 +84,7 @@ mh $ invalidateCacheEntry ScriptHelpText _ -> return () - mode <- use csMode + mode <- gets appMode case mode of Main -> onEventMain e ShowHelp _ -> onEventShowHelp e @@ -108,7 +111,7 @@ let wasMentioned = case wepMentions (weData we) of Just lst -> myUserId `Set.member` lst _ -> False - addMessageToState (RecentPost p wasMentioned) >>= postProcessMessageAdd + addNewPostedMessage $ RecentPost p wasMentioned | otherwise -> return () WMPostEdited @@ -133,7 +136,7 @@ | otherwise -> return () WMNewUser - | Just uId <- wepUserId $ weData we -> handleNewUser uId + | Just uId <- wepUserId $ weData we -> handleNewUsers (Seq.singleton uId) | otherwise -> return () WMUserRemoved @@ -190,11 +193,11 @@ | otherwise -> return () WMChannelViewed - | Just cId <- webChannelId $ weBroadcast we -> refreshChannelById False cId + | Just cId <- wepChannelId $ weData we -> refreshChannelById cId | otherwise -> return () WMChannelUpdated - | Just cId <- webChannelId $ weBroadcast we -> refreshChannelById False cId + | Just cId <- webChannelId $ weBroadcast we -> refreshChannelById cId | otherwise -> return () WMGroupAdded diff --git a/src/Events/ChannelScroll.hs b/src/Events/ChannelScroll.hs --- a/src/Events/ChannelScroll.hs +++ b/src/Events/ChannelScroll.hs @@ -26,7 +26,7 @@ , mkKb PageDownEvent "Scroll down" channelPageDown , mkKb CancelEvent "Cancel scrolling and return to channel view" $ - csMode .= Main + setMode Main , mkKb ScrollTopEvent "Scroll to top" channelScrollToTop , mkKb ScrollBottomEvent "Scroll to bottom" diff --git a/src/Events/ChannelSelect.hs b/src/Events/ChannelSelect.hs --- a/src/Events/ChannelSelect.hs +++ b/src/Events/ChannelSelect.hs @@ -29,11 +29,11 @@ (Vty.EvKey Vty.KEnter []) $ do selMatch <- use (csChannelSelectState.selectedMatch) - csMode .= Main + setMode Main when (selMatch /= "") $ do changeChannel selMatch - , mkKb CancelEvent "Cancel channel selection" $ csMode .= Main + , mkKb CancelEvent "Cancel channel selection" $ setMode Main , mkKb NextChannelEvent "Select next match" channelSelectNext , mkKb PrevChannelEvent "Select previous match" channelSelectPrevious ] diff --git a/src/Events/DeleteChannelConfirm.hs b/src/Events/DeleteChannelConfirm.hs --- a/src/Events/DeleteChannelConfirm.hs +++ b/src/Events/DeleteChannelConfirm.hs @@ -4,7 +4,6 @@ import Prelude.Compat import qualified Graphics.Vty as Vty -import Lens.Micro.Platform import Types import State @@ -15,6 +14,6 @@ Vty.KChar c | c `elem` ("yY"::String) -> deleteCurrentChannel _ -> return () - csMode .= Main + setMode Main onEventDeleteChannelConfirm _ = do - csMode .= Main + setMode Main diff --git a/src/Events/JoinChannel.hs b/src/Events/JoinChannel.hs --- a/src/Events/JoinChannel.hs +++ b/src/Events/JoinChannel.hs @@ -35,6 +35,6 @@ Nothing -> return () Just (_, chan) -> joinChannel chan onEventJoinChannel (Vty.EvKey Vty.KEsc []) = do - csMode .= Main + setMode Main onEventJoinChannel _ = do return () diff --git a/src/Events/Keybindings.hs b/src/Events/Keybindings.hs --- a/src/Events/Keybindings.hs +++ b/src/Events/Keybindings.hs @@ -1,6 +1,7 @@ module Events.Keybindings ( defaultBindings , lookupKeybinding + , getFirstDefaultBinding , mkKb , staticKb @@ -18,6 +19,7 @@ , keyEventFromName ) where +import Data.Monoid ((<>)) import qualified Data.Map.Strict as M import qualified Data.Text as T import qualified Graphics.Vty as Vty @@ -71,6 +73,12 @@ bindingToEvent :: Binding -> Vty.Event bindingToEvent binding = Vty.EvKey (kbKey binding) (kbMods binding) + +getFirstDefaultBinding :: KeyEvent -> Binding +getFirstDefaultBinding ev = + case defaultBindings ev of + [] -> error $ "BUG: event " <> show ev <> " has no default bindings!" + (b:_) -> b defaultBindings :: KeyEvent -> [Binding] defaultBindings ev = diff --git a/src/Events/LeaveChannelConfirm.hs b/src/Events/LeaveChannelConfirm.hs --- a/src/Events/LeaveChannelConfirm.hs +++ b/src/Events/LeaveChannelConfirm.hs @@ -4,7 +4,6 @@ import Prelude.Compat import qualified Graphics.Vty as Vty -import Lens.Micro.Platform import Types import State @@ -15,5 +14,5 @@ Vty.KChar c | c `elem` ("yY"::String) -> leaveCurrentChannel _ -> return () - csMode .= Main + setMode Main onEventLeaveChannelConfirm _ = return () diff --git a/src/Events/Main.hs b/src/Events/Main.hs --- a/src/Events/Main.hs +++ b/src/Events/Main.hs @@ -110,7 +110,7 @@ mh $ invalidateCacheEntry vp mh $ vScrollToEnd $ viewportScroll vp mh $ vScrollBy (viewportScroll vp) (-1 * pageAmount) - csMode .= ChannelScroll + setMode ChannelScroll , mkKb NextChannelEvent "Change to the next channel in the channel list" nextChannel @@ -171,9 +171,9 @@ csEditState.cedInputHistory %= addHistoryEntry allLines cId csEditState.cedInputHistoryPosition.at cId .= Nothing - case T.uncons line of - Just ('/',cmd) -> dispatchCommand cmd - _ -> sendMessage mode allLines + case T.uncons allLines of + Just ('/', cmd) -> dispatchCommand cmd + _ -> sendMessage mode allLines -- Reset the edit mode *after* handling the input so that the input -- handler can tell whether we're editing, replying, etc. diff --git a/src/Events/MessageSelect.hs b/src/Events/MessageSelect.hs --- a/src/Events/MessageSelect.hs +++ b/src/Events/MessageSelect.hs @@ -6,7 +6,6 @@ import Data.Monoid ((<>)) import qualified Data.Text as T import qualified Graphics.Vty as Vty -import Lens.Micro.Platform import Types import Events.Keybindings @@ -22,14 +21,14 @@ onEventMessageSelectDeleteConfirm :: Vty.Event -> MH () onEventMessageSelectDeleteConfirm (Vty.EvKey (Vty.KChar 'y') []) = do deleteSelectedMessage - csMode .= Main + setMode Main onEventMessageSelectDeleteConfirm _ = - csMode .= Main + setMode Main messageSelectKeybindings :: KeyConfig -> [Keybinding] messageSelectKeybindings = mkKeybindings [ mkKb CancelEvent "Cancel message selection" $ - csMode .= Main + setMode Main , mkKb SelectUpEvent "Select the previous message" messageSelectUp , mkKb SelectDownEvent "Select the next message" messageSelectDown diff --git a/src/Events/ShowHelp.hs b/src/Events/ShowHelp.hs --- a/src/Events/ShowHelp.hs +++ b/src/Events/ShowHelp.hs @@ -5,7 +5,6 @@ import Brick import qualified Graphics.Vty as Vty -import Lens.Micro.Platform import Types import Events.Keybindings @@ -14,7 +13,7 @@ onEventShowHelp :: Vty.Event -> MH () onEventShowHelp = handleKeyboardEvent helpKeybindings $ \ e -> case e of - Vty.EvKey _ _ -> csMode .= Main + Vty.EvKey _ _ -> setMode Main _ -> return () helpKeybindings :: KeyConfig -> [Keybinding] @@ -28,7 +27,7 @@ , mkKb PageDownEvent "Page down" $ mh $ vScrollBy (viewportScroll HelpViewport) (1 * pageAmount) , mkKb CancelEvent "Return to the main interface" $ - csMode .= Main + setMode Main ] -- 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 @@ -5,7 +5,6 @@ import Brick.Widgets.List import qualified Graphics.Vty as Vty -import Lens.Micro.Platform import Types import Events.Keybindings @@ -21,7 +20,7 @@ [ staticKb "Open the selected URL, if any" (Vty.EvKey Vty.KEnter []) $ do openSelectedURL - csMode .= Main + setMode Main , mkKb CancelEvent "Cancel URL selection" stopUrlSelect diff --git a/src/Login.hs b/src/Login.hs --- a/src/Login.hs +++ b/src/Login.hs @@ -86,10 +86,10 @@ mkForm :: ConnectionInfo -> Form ConnectionInfo e Name mkForm = let label s w = padBottom (Pad 1) $ - (vLimit 1 $ hLimit 15 $ str s <+> fill ' ') <+> w - in newForm [ label "Hostname:" @@= + (vLimit 1 $ hLimit 18 $ str s <+> fill ' ') <+> w + in newForm [ label "Server hostname:" @@= editHostname ciHostname Hostname - , label "Port:" @@= + , label "Server port:" @@= editShowableField ciPort Port , label "Username:" @@= editTextField ciUsername Username (Just 1) @@ -137,7 +137,7 @@ renderError = withDefAttr errorAttr uiWidth :: Int -uiWidth = 50 +uiWidth = 60 credentialsForm :: State -> Widget Name credentialsForm st = diff --git a/src/Markdown.hs b/src/Markdown.hs --- a/src/Markdown.hs +++ b/src/Markdown.hs @@ -22,6 +22,7 @@ import Brick ( (<+>), Widget, textWidth ) import qualified Brick.Widgets.Border as B import qualified Brick.Widgets.Border.Style as B +import qualified Brick.Widgets.Skylighting as BS import qualified Brick as B import Cheapskate.Types ( Block , Blocks @@ -103,7 +104,9 @@ { mdEditThreshold :: Maybe ServerTime , mdShowOlderEdits :: Bool , mdMessage :: Message + , mdUserName :: Maybe T.Text , mdParentMessage :: Maybe Message + , mdParentUserName :: Maybe T.Text , mdRenderReplyParent :: Bool , mdHighlightSet :: HighlightSet , mdIndentBlocks :: Bool @@ -123,7 +126,7 @@ -- shown for old messages (i.e., ignore the mdEditThreshold value). renderMessage :: MessageData -> Widget a renderMessage md@MessageData { mdMessage = msg, .. } = - let msgUsr = case msg^.mUserName of + let msgUsr = case mdUserName of Just u | msg^.mType `elem` omitUsernameTypes -> Nothing | otherwise -> Just u @@ -174,6 +177,7 @@ let parentMsg = renderMessage md { mdShowOlderEdits = False , mdMessage = pm + , mdUserName = mdParentUserName , mdParentMessage = Nothing , mdRenderReplyParent = False , mdIndentBlocks = False @@ -305,15 +309,7 @@ Right tokLines -> let padding = B.padLeftRight 1 (B.vLimit (length tokLines) B.vBorder) in (B.txt $ "[" <> Sky.sName syntax <> "]") B.<=> - (padding <+> (B.vBox $ renderTokenLine <$> tokLines)) - -renderTokenLine :: Sky.SourceLine -> Widget a -renderTokenLine [] = B.str " " -renderTokenLine toks = B.hBox $ renderToken <$> toks - -renderToken :: Sky.Token -> Widget a -renderToken (ty, tx) = - B.withDefAttr (attrNameForTokenType ty) $ textWithCursor tx + (padding <+> BS.renderRawSource textWithCursor tokLines) rawCodeBlockToWidget :: T.Text -> Widget a rawCodeBlockToWidget tx = diff --git a/src/State.hs b/src/State.hs --- a/src/State.hs +++ b/src/State.hs @@ -19,6 +19,7 @@ , startJoinChannel , joinChannel , changeChannel + , disconnectChannels , startLeaveCurrentChannel , leaveCurrentChannel , leaveChannel @@ -54,11 +55,11 @@ , msgURLs , editMessage , deleteMessage - , addMessageToState - , postProcessMessageAdd + , addNewPostedMessage + , fetchVisibleIfNeeded -- * Working with users - , handleNewUser + , handleNewUsers , updateStatus , handleTypingUser @@ -121,7 +122,7 @@ import Data.Char (isAlphaNum) import Brick.Main (getVtyHandle, viewportScroll, vScrollToBeginning, vScrollBy, vScrollToEnd) import Brick.Widgets.Edit (applyEdit) -import Control.Monad (when, unless, void, forM_) +import Control.Monad (when, unless, void, forM_, join) import qualified Data.ByteString as BS import Data.Function (on) import Data.Text.Zipper (textZipper, clearZipper, insertMany, gotoEOL) @@ -152,6 +153,7 @@ import Config import FilePaths +import TimeUtils (justBefore, justAfter) import Types import Types.Channels import Types.Posts @@ -165,6 +167,7 @@ import Markdown (blockGetURLs, findVerbatimChunk) import State.Common +import State.Messages import State.Setup.Threads (updateUserStatuses) -- * Refreshing Channel Data @@ -172,10 +175,9 @@ -- | Refresh information about a specific channel. The channel -- metadata is refreshed, and if this is a loaded channel, the -- scrollback is updated as well. -refreshChannel :: Bool -> Channel -> ChannelMember -> MH () -refreshChannel refreshMessages chan member = do +refreshChannel :: Channel -> ChannelMember -> MH () +refreshChannel chan member = do let cId = getId chan - curId <- use csCurrentChannelId -- If this is a group channel that the user has chosen to hide, ignore -- the refresh request. @@ -190,19 +192,13 @@ updateChannelInfo cId chan member - -- If this is an active channel or the current channel, also - -- update the Messages to retrieve any that might have been - -- missed. - when (refreshMessages || (cId == curId)) $ - updateMessages cId - -refreshChannelById :: Bool -> ChannelId -> MH () -refreshChannelById refreshMessages cId = do +refreshChannelById :: ChannelId -> MH () +refreshChannelById cId = do session <- use (csResources.crSession) doAsyncWith Preempt $ do cwd <- MM.mmGetChannel cId session member <- MM.mmGetChannelMember cId UserMe session - return $ refreshChannel refreshMessages cwd member + return $ refreshChannel cwd member createGroupChannel :: T.Text -> MH () createGroupChannel usernameList = do @@ -262,7 +258,7 @@ (Nothing, True) -> -- If it has been set to showing and we are not showing -- it, ask for a load/refresh. - refreshChannelById True cId + refreshChannelById cId _ -> return () applyPreferenceChange _ = return () @@ -306,14 +302,19 @@ Just _ -> return () Nothing -> handleNewUserDirect u - forM_ chansWithData $ uncurry (refreshChannel True) + forM_ chansWithData $ uncurry refreshChannel userSet <- use (csResources.crUserIdSet) liftIO $ STM.atomically $ STM.writeTVar userSet (fmap userId users) lock <- use (csResources.crUserStatusLock) doAsyncWith Preempt $ updateUserStatuses userSet lock session --- | Update the indicted Channel entry with the new data retrieved from +-- | 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 @@ -348,88 +349,7 @@ -- Flush cnChans csNames.cnChans %= filter (/= name) --- | If this channel has content, fetch any new content that has --- arrived after the existing content. -updateMessages :: ChannelId -> MH () -updateMessages cId = - withChannel cId $ \chan -> do - when (chan^.ccInfo.cdCurrentState.to (`elem` [ChanLoaded, ChanInitialSelect])) $ do - curId <- use csCurrentChannelId - let priority = if curId == cId then Preempt else Normal - asyncFetchScrollback priority cId --- | Fetch scrollback for a channel in the background. This may be --- called to fetch messages in a number of situations, including: --- --- 1. WebSocket connect at init, no messages available --- --- 2. WebSocket reconnect after losing connectivity for a period --- --- 3. Channel selected by user --- --- a. No current messages fetched yet --- --- b. Messages may have been provided unsolicited via the --- WebSocket. --- --- 4. User got invited to the channel (by another user). --- --- For most cases, fetching the most recent set of messages is --- appropriate, but for case 2, messages from the most recent forward --- should be retrieved. However, be careful not to confuse case 2 --- with case 3b. -asyncFetchScrollback :: AsyncPriority -> ChannelId -> MH () -asyncFetchScrollback prio cId = do - withChannel cId $ \chan -> do - let last_pId = getLatestPostId (chan^.ccContents.cdMessages) - newCutoff = chan^.ccInfo.cdNewMessageIndicator - fetchMessages s _ c = do - let fc = case last_pId of - Nothing -> F1 -- or F4 - Just pId -> - case findMessage pId (chan^.ccContents.cdMessages) of - Nothing -> F4 -- This should never happen since - -- we just assigned pId. - Just m -> - case newCutoff of - Hide -> - -- No cutoff has been set, so we - -- just ask for the most recent - -- messages. - F2 pId - NewPostsAfterServerTime ct -> - -- If the most recent message is - -- after the cutoff, meaning there - -- might be intervening messages - -- that we missed. - if m^.mDate > ct - then F3b pId - else F3a - NewPostsStartingAt ct -> - -- If the most recent message is - -- after the cutoff, meaning there - -- might be intervening messages - -- that we missed. - if m^.mDate >= ct - then F3b pId - else F3a - query = MM.defaultPostQuery - { MM.postQueryPage = Just 0 - , MM.postQueryPerPage = Just numScrollbackPosts - } - finalQuery = case fc of - F1 -> query -- mmGetPosts s t c - F2 pId -> query { MM.postQueryAfter = Just pId } -- mmGetPostsAfter s t c pId - F3a -> query -- mmGetPosts s t c - F3b pId -> query { MM.postQueryBefore = Just pId } -- mmGetPostsBefore s t c pId - F4 -> query -- mmGetPosts s t c - MM.mmGetPostsForChannel c finalQuery s -- op 0 numScrollbackPosts - - asPending doAsyncChannelMM prio cId fetchMessages - addObtainedMessages - -data FetchCase = F1 | F2 PostId | F3a | F3b PostId | F4 deriving (Eq,Show) - -- * Message selection mode beginMessageSelect :: MH () @@ -442,15 +362,15 @@ -- If we can't find one at all, we ignore the mode switch request -- and just return. chanMsgs <- use(csCurrentChannel . ccContents . cdMessages) - let recentPost = getLatestPostId chanMsgs + let recentPost = getLatestPostMsg chanMsgs when (isJust recentPost) $ do - csMode .= MessageSelect - csMessageSelect .= MessageSelectState recentPost + setMode MessageSelect + csMessageSelect .= MessageSelectState (join $ ((^.mPostId) <$> recentPost)) getSelectedMessage :: ChatState -> Maybe Message getSelectedMessage st - | st^.csMode /= MessageSelect && st^.csMode /= MessageSelectDeleteConfirm = Nothing + | appMode st /= MessageSelect && appMode st /= MessageSelectDeleteConfirm = Nothing | otherwise = do selPostId <- selectMessagePostId $ st^.csMessageSelect @@ -459,7 +379,7 @@ messageSelectUp :: MH () messageSelectUp = do - mode <- use csMode + mode <- gets appMode selected <- use (csMessageSelect.to selectMessagePostId) case selected of Just _ | mode == MessageSelect -> do @@ -470,10 +390,9 @@ messageSelectDown :: MH () messageSelectDown = do - mode <- use csMode selected <- use (csMessageSelect.to selectMessagePostId) case selected of - Just _ | mode == MessageSelect -> do + Just _ -> whenMode MessageSelect $ do chanMsgs <- use (csCurrentChannel.ccContents.cdMessages) let nextPostId = getNextPostId selected chanMsgs csMessageSelect .= MessageSelectState (nextPostId <|> selected) @@ -493,7 +412,7 @@ beginConfirmDeleteSelectedMessage :: MH () beginConfirmDeleteSelectedMessage = - csMode .= MessageSelectDeleteConfirm + setMode MessageSelectDeleteConfirm deleteSelectedMessage :: MH () deleteSelectedMessage = do @@ -507,7 +426,7 @@ doAsyncChannelMM Preempt cId (\s _ _ -> MM.mmDeletePost (postId p) s) (\_ _ -> do csEditState.cedEditMode .= NewPost - csMode .= Main) + setMode Main) Nothing -> return () _ -> return () @@ -517,12 +436,12 @@ withChannel cId $ \chan -> do let chType = chan^.ccInfo.cdType if chType /= Direct - then csMode .= DeleteChannelConfirm + then setMode DeleteChannelConfirm else postErrorMessage "The /delete-channel command cannot be used with direct message channels." deleteCurrentChannel :: MH () deleteCurrentChannel = do - csMode .= Main + setMode Main cId <- use csCurrentChannelId leaveChannelIfPossible cId True @@ -532,44 +451,6 @@ isRecentChannel :: ChatState -> ChannelId -> Bool isRecentChannel st cId = st^.csRecentChannel == Just cId --- | Update the UI to reflect the flagged/unflagged state of a --- message. This __does not__ talk to the Mattermost server, but --- rather is the function we call when the Mattermost server notifies --- 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 <- use csMode - 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 () -- | Tell the server that we have flagged or unflagged a message. flagMessage :: PostId -> Bool -> MH () @@ -599,7 +480,7 @@ case selected of Just msg | isMine st msg && isEditable msg -> do let Just p = msg^.mOriginalPost - csMode .= Main + setMode Main csEditState.cedEditMode .= Editing p csEditState.cedEditor %= applyEdit (clearZipper >> (insertMany $ postMessage p)) _ -> return () @@ -609,7 +490,7 @@ msgs <- use (csCurrentChannel . ccContents . cdMessages) case findLatestUserMessage isReplyable msgs of Just msg -> do let Just p = msg^.mOriginalPost - csMode .= Main + setMode Main csEditState.cedEditMode .= Replying msg p _ -> return () @@ -620,7 +501,7 @@ Nothing -> return () Just msg -> do let Just p = msg^.mOriginalPost - csMode .= Main + setMode Main csEditState.cedEditMode .= Replying msg p cancelReplyOrEdit :: MH () @@ -641,7 +522,7 @@ Nothing -> return () Just txt -> do copyToClipboard txt - csMode .= Main + setMode Main -- * Joining, Leaving, and Inviting @@ -666,12 +547,12 @@ return $ do csJoinChannelList .= (Just $ list JoinChannelList sortedChans 2) - csMode .= JoinChannel + setMode JoinChannel csJoinChannelList .= Nothing joinChannel :: Channel -> MH () joinChannel chan = do - csMode .= Main + setMode Main myId <- use (csMe.userIdL) let member = MinChannelMember myId (getId chan) doAsyncChannelMM Preempt (getId chan) (\ s _ c -> MM.mmAddUser c member s) endAsyncNOP @@ -684,9 +565,7 @@ doAsyncWith Normal $ do member <- MM.mmGetChannelMember cId UserMe (st^.csResources.crSession) tryMM (MM.mmGetChannel cId (st^.csResources.crSession)) - (\cwd -> return $ do - handleNewChannel False cwd member - asyncFetchScrollback Normal cId) + (\cwd -> return $ handleNewChannel False cwd member) addUserToCurrentChannel :: T.Text -> MH () addUserToCurrentChannel uname = do @@ -721,7 +600,7 @@ startLeaveCurrentChannel = do cInfo <- use (csCurrentChannel.ccInfo) case canLeaveChannel cInfo of - True -> csMode .= LeaveChannelConfirm + True -> setMode LeaveChannelConfirm False -> postErrorMessage "The /leave command cannot be used with this channel." leaveCurrentChannel :: MH () @@ -945,7 +824,6 @@ postChangeChannelCommon :: MH () postChangeChannelCommon = do resetHistoryPosition - fetchCurrentScrollback resetEditorState updateChannelListScroll loadLastEdit @@ -1061,29 +939,157 @@ asyncFetchMoreMessages = do cId <- use csCurrentChannelId withChannel cId $ \chan -> - let offset = length $ chan^.ccContents.cdMessages + 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 } - in asPending doAsyncChannelMM Preempt cId + & \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 p + (\c p -> do addObtainedMessages c (-pageAmount) p >>= postProcessMessageAdd mh $ invalidateCacheEntry (ChannelMessages cId)) -addObtainedMessages :: ChannelId -> Posts -> MH () -addObtainedMessages _cId posts = - postProcessMessageAdd =<< - foldl mappend mempty <$> - mapM (addMessageToState . OldPost) - [ (posts^.postsPostsL) HM.! p - | p <- F.toList (posts^.postsOrderL) - ] +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 = F.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 mappend mempty <$> + mapM (addMessageToState . OldPost) + [ (posts^.postsPostsL) HM.! p + | p <- F.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 st inputUserIds = + let knownUserIds = allUserIds (st^.csUsers) + unknownUsers = Set.difference inputUserIds knownUserIds + in if Set.null unknownUsers + then return () + else handleNewUsers $ Seq.fromList $ F.toList unknownUsers + + st <- use id + addUnknownUsers st users + + -- Return the aggregated user notification action needed + -- relative to the set of added messages. + + return action + + loadMoreMessages :: MH () -loadMoreMessages = do - mode <- use csMode - when (mode == ChannelScroll) asyncFetchMoreMessages +loadMoreMessages = whenMode ChannelScroll asyncFetchMoreMessages channelByName :: ChatState -> T.Text -> Maybe ChannelId channelByName st n @@ -1184,8 +1190,8 @@ Just _ -> return () Nothing -> do -- Create a new ClientChannel structure - let cChannel = makeClientChannel nc & - ccInfo %~ channelInfoFromChannelWithData nc member + cChannel <- (ccInfo %~ channelInfoFromChannelWithData nc member) <$> + makeClientChannel nc st <- use id @@ -1231,7 +1237,7 @@ case permitPostpone of False -> return $ Just $ channelName nc True -> do - handleNewUser otherUserId + handleNewUsers $ Seq.singleton otherUserId doAsyncWith Normal $ return $ handleNewChannel_ False switch nc member return Nothing @@ -1260,10 +1266,9 @@ editMessage :: Post -> MH () editMessage new = do - st <- use id myId <- use (csMe.userIdL) let isEditedMessage m = m^.mPostId == Just (new^.postIdL) - msg = clientPostToMessage st (toClientPost new (new^.postParentIdL)) + msg = clientPostToMessage (toClientPost new (new^.postParentIdL)) chan = csChannel (new^.postChannelIdL) chan . ccContents . cdMessages . traversed . filtered isEditedMessage .= msg @@ -1317,11 +1322,7 @@ -- | postProcessMessageAdd performs the actual actions indicated by -- the corresponding input value. postProcessMessageAdd :: PostProcessMessageAdd -> MH () -postProcessMessageAdd ppma = do - postOp ppma - cState <- use (csCurrentChannel.ccInfo.cdCurrentState) - when (cState == ChanInitialSelect) $ - csCurrentChannel.ccInfo.cdCurrentState .= ChanLoaded +postProcessMessageAdd ppma = postOp ppma where postOp NoAction = return () postOp UpdateServerViewed = updateViewed @@ -1344,9 +1345,11 @@ -- constructor). -- | Adds a possibly new message to the associated channel contents. --- Returns True if this is something that should potentially notify --- the user of a change to the channel (i.e., not a message we --- posted). +-- 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 @@ -1367,17 +1370,22 @@ let chType = nc^.channelTypeL pref = showGroupChannelPref (postChannelId new) (st^.csMe.userIdL) - 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 True nc member + -- 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 + addMessageToState newPostData >>= postProcessMessageAdd return NoAction Just _ -> do @@ -1388,9 +1396,8 @@ doAddMessage = do currCId <- use csCurrentChannelId - s <- use id -- use *latest* state flags <- use (csResources.crFlaggedPosts) - let msg' = clientPostToMessage s cp + let msg' = clientPostToMessage cp & mFlagged .~ ((cp^.cpPostId) `Set.member` flags) csPostMap.at(postId new) .= Just msg' csChannels %= modifyChannelById cId @@ -1420,9 +1427,8 @@ doAsyncChannelMM Preempt cId (\s _ _ -> MM.mmGetThread parentId s) (\_ p -> do - st' <- use id let postMap = HM.fromList [ ( pId - , clientPostToMessage st' + , clientPostToMessage (toClientPost x (x^.postParentIdL)) ) | (pId, x) <- HM.toList (p^.postsPostsL) @@ -1450,17 +1456,7 @@ else NoAction return $ curChannelAction <> originUserAction - -- If this message was written by a user we don't know about, - -- fetch the user's information before posting the message. - case cp^.cpUser of - Nothing -> doHandleAddedMessage - Just uId -> - case st^.csUsers.to (findUserById uId) of - Just _ -> doHandleAddedMessage - Nothing -> do - handleNewUser uId - doAsyncWith Normal $ return (doHandleAddedMessage >> return ()) - postedChanMessage + doHandleAddedMessage getNewMessageCutoff :: ChannelId -> ChatState -> Maybe NewMessageIndicator getNewMessageCutoff cId st = do @@ -1472,25 +1468,40 @@ cc <- st^?csChannel(cId) cc^.ccInfo.cdEditedMessageThreshold -fetchCurrentScrollback :: MH () -fetchCurrentScrollback = do - cId <- use csCurrentChannelId - withChannel cId $ \ chan -> do - unless (chan^.ccInfo.cdCurrentState `elem` [ChanLoaded, ChanInitialSelect]) $ do - -- Upgrades the channel state to "Loaded" to indicate that - -- content is now present (this is the main point where channel - -- state is switched from metadata-only to with-content), then - -- initiates an operation to read the content (which will change - -- the state to a pending for loaded. If there was an async - -- background task pending (esp. if this channel was selected - -- just after startup and startup fetching is still underway), - -- this will potentially schedule a duplicate, but that will not - -- be harmful since quiescent channel states only increase to - -- "higher" states. - when (chan^.ccInfo.cdCurrentState /= ChanInitialSelect) $ - csChannel(cId).ccInfo.cdCurrentState .= ChanLoaded - asyncFetchScrollback Preempt 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^.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 () + mkChannelZipperList :: MMNames -> [ChannelId] mkChannelZipperList chanNames = [ (chanNames ^. cnToChanId) HM.! i @@ -1557,11 +1568,11 @@ showHelpScreen :: HelpTopic -> MH () showHelpScreen topic = do mh $ vScrollToBeginning (viewportScroll HelpViewport) - csMode .= ShowHelp topic + setMode $ ShowHelp topic beginChannelSelect :: MH () beginChannelSelect = do - csMode .= ChannelSelect + setMode ChannelSelect csChannelSelectState .= emptyChannelSelectState -- Select the next match in channel selection mode. @@ -1686,11 +1697,11 @@ startUrlSelect :: MH () startUrlSelect = do urls <- use (csCurrentChannel.to findUrls.to V.fromList) - csMode .= UrlSelect + setMode UrlSelect csUrlList .= (listMoveTo (length urls - 1) $ list UrlList urls 2) stopUrlSelect :: MH () -stopUrlSelect = csMode .= Main +stopUrlSelect = setMode Main findUrls :: ClientChannel -> [LinkChoice] findUrls chan = @@ -1718,24 +1729,24 @@ removeDuplicates = nubOn (\ l -> (l^.linkURL, l^.linkUser)) msgURLs :: Message -> Seq.Seq LinkChoice -msgURLs msg | Just uname <- msg^.mUserName = - let msgUrls = (\ (url, text) -> LinkChoice (msg^.mDate) uname text url Nothing) <$> +msgURLs msg + | NoUser <- msg^.mUser = mempty + | otherwise = + let uid = msg^.mUser + msgUrls = (\ (url, text) -> LinkChoice (msg^.mDate) uid text url Nothing) <$> (mconcat $ blockGetURLs <$> (F.toList $ msg^.mText)) attachmentURLs = (\ a -> LinkChoice (msg^.mDate) - uname + uid ("attachment `" <> (a^.attachmentName) <> "`") (a^.attachmentURL) (Just (a^.attachmentFileId))) <$> (msg^.mAttachments) in msgUrls <> attachmentURLs -msgURLs _ = mempty openSelectedURL :: MH () -openSelectedURL = do - mode <- use csMode - when (mode == UrlSelect) $ do +openSelectedURL = whenMode UrlSelect $ do selected <- use (csUrlList.to listSelectedElement) case selected of Nothing -> return () @@ -1744,7 +1755,7 @@ when (not opened) $ do let msg = "Config option 'urlOpenCommand' missing; cannot open URL." postInfoMessage msg - csMode .= Main + setMode Main openURL :: LinkChoice -> MH Bool openURL link = do @@ -1789,11 +1800,15 @@ 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 st void $ runInteractiveCommand (T.unpack urlOpenCommand) args - return $ st & csMode .~ Main + return $ setMode' Main st return True @@ -1875,18 +1890,16 @@ "https://github.com/matterhorn-chat/matterhorn" openSelectedMessageURLs :: MH () -openSelectedMessageURLs = do - mode <- use csMode - when (mode == 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 -> csMode .= Main - False -> do - let msg = "Config option 'urlOpenCommand' missing; cannot open URL." - postInfoMessage msg +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 -> do + let msg = "Config option 'urlOpenCommand' missing; cannot open URL." + postInfoMessage msg shouldSkipMessage :: T.Text -> Bool shouldSkipMessage "" = True @@ -1926,28 +1939,26 @@ userSet <- use (csResources.crUserIdSet) liftIO $ STM.atomically $ STM.modifyTVar userSet $ (newUserId Seq.<|) -handleNewUser :: UserId -> MH () -handleNewUser newUserId = doAsyncMM Normal getUserInfo updateUserState +handleNewUsers :: Seq.Seq UserId -> MH () +handleNewUsers newUserIds = doAsyncMM Preempt getUserInfo updateUserStates where getUserInfo session _ = - do (nUser, users) <- concurrently (MM.mmGetUser (UserById newUserId) session) - (MM.mmGetUsers MM.defaultUserQuery - { MM.userQueryPage = Just 0 - , MM.userQueryPerPage = Just 10000 - } session) - let teamUsers = HM.fromList [ (userId u, u) | u <- F.toList users ] - -- Also re-load the team members so we can tell - -- whether the new user is in the current user's - -- team. - let usrInfo = userInfoFromUser nUser (HM.member newUserId teamUsers) - return (nUser, usrInfo) + do nUsers <- MM.mmGetUsersByIds newUserIds session + let usrInfo u = userInfoFromUser u True + usrList = F.toList nUsers + return $ zip usrList (usrInfo <$> usrList) + + updateUserStates :: [(User, UserInfo)] -> MH () + updateUserStates pairs = mapM_ updateUserState pairs + updateUserState :: (User, UserInfo) -> MH () updateUserState (newUser, uInfo) = -- Update the name map and the list of known users - do csUsers %= addUser newUserId uInfo + do let uId = userId newUser + csUsers %= addUser uId uInfo csNames . cnUsers %= (sort . ((newUser^.userUsernameL):)) - csNames . cnToUserId . at (newUser^.userUsernameL) .= Just newUserId + csNames . cnToUserId . at (newUser^.userUsernameL) .= Just uId userSet <- use (csResources.crUserIdSet) - liftIO $ STM.atomically $ STM.modifyTVar userSet $ (newUserId Seq.<|) + liftIO $ STM.atomically $ STM.modifyTVar userSet $ (uId Seq.<|) -- | Handle the typing events from the websocket to show the currently typing users on UI handleTypingUser :: UserId -> ChannelId -> MH () diff --git a/src/State/Common.hs b/src/State/Common.hs --- a/src/State/Common.hs +++ b/src/State/Common.hs @@ -164,24 +164,6 @@ doAsyncChannelMM prio cId mmOp eventHandler = doAsyncMM prio (\s t -> mmOp s t cId) (eventHandler cId) --- | Prefix function for calling doAsyncChannelMM that will set the --- channel state to "pending" until the async operation completes. If --- the channel state is already in the pending state when this --- function is called, no operations are performed (i.e., this request --- is treated as a duplicate). -asPending :: DoAsyncChannelMM a -> DoAsyncChannelMM a -asPending asyncOp prio cId mmOp eventHandler = do - withChannel cId $ \chan -> - let origState = chan^.ccInfo.cdCurrentState - (pendState, setDone) = pendingChannelState origState - in if pendState == origState - then return () -- this operation already pending; do not duplicate - else do - csChannel(cId).ccInfo.cdCurrentState .= pendState - asyncOp prio cId mmOp $ \_ r -> - do csChannel(cId).ccInfo.cdCurrentState %= setDone - eventHandler cId r - -- | Use this convenience function if no operation needs to be -- performed in the MH state after an async operation completes. endAsyncNOP :: ChannelId -> a -> MH () @@ -189,28 +171,18 @@ -- * Client Messages --- | Create 'ChannelContents' from a 'Posts' value -fromPosts :: Posts -> MH ChannelContents -fromPosts ps = do - msgs <- messagesFromPosts ps - F.forM_ (ps^.postsPostsL) $ - asyncFetchAttachments - return (ChannelContents msgs) - messagesFromPosts :: Posts -> MH Messages messagesFromPosts p = do - st <- use id flags <- use (csResources.crFlaggedPosts) - csPostMap %= HM.union (postMap st) - st' <- use id - let msgs = postsToMessages (maybeFlag flags . clientPostToMessage st') (clientPost <$> ps) + csPostMap %= HM.union postMap + let msgs = postsToMessages (maybeFlag flags . clientPostToMessage) (clientPost <$> ps) postsToMessages f = foldr (addMessage . f) noMessages return msgs where - postMap :: ChatState -> HM.HashMap PostId Message - postMap st = HM.fromList + postMap :: HM.HashMap PostId Message + postMap = HM.fromList [ ( pId - , clientPostToMessage st (toClientPost x Nothing) + , clientPostToMessage (toClientPost x Nothing) ) | (pId, x) <- HM.toList (p^.postsPostsL) ] diff --git a/src/State/Messages.hs b/src/State/Messages.hs new file mode 100644 --- /dev/null +++ b/src/State/Messages.hs @@ -0,0 +1,112 @@ +module State.Messages + ( addDisconnectGaps + , loadFlaggedMessages + , updateMessageFlag + , lastMsg + ) + where + + +import Control.Monad (unless) +import qualified Data.Foldable as F +import Data.Function (on) +import qualified Data.Sequence as Seq +import qualified Data.Set as Set +import qualified Data.Text as T +import Lens.Micro.Platform +import Network.Mattermost +import Network.Mattermost.Types +import State.Common +import TimeUtils +import Types +import Types.Channels +import Types.Messages +import Types.Posts + + +-- ---------------------------------------------------------------------- +-- Message gaps + + +-- | Called to add an UnknownGap to the end of the Messages collection +-- for all channels when the client has become disconnected from the +-- server. This gaps will later be removed by successful fetching +-- overlaps if the connection is re-established. Note that the +-- disconnect is re-iterated periodically via a re-connect timer +-- attempt, so do not duplicate gaps. Also clear any flags +-- representing a pending exchange with the server (which will now +-- never complete). +addDisconnectGaps :: MH () +addDisconnectGaps = mapM_ onEach . filteredChannelIds (const True) =<< use csChannels + where onEach c = do addEndGap c + clearPendingFlags c + +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 + lastIsGap = maybe False isGap lastmsg_ + gapMsg = newGapMessage timeJustAfterLast + timeJustAfterLast = maybe t0 (justAfter . _mDate) lastmsg_ + t0 = ServerTime $ originTime -- use any time for a channel with no messages yet + newGapMessage = newMessageOfType (T.pack "Disconnected. Will refresh when connected.") (C UnknownGap) + in unless lastIsGap + (csChannels %= modifyChannelById cId (ccContents.cdMessages %~ addMessage gapMsg)) + + +lastMsg :: RetrogradeMessages -> Maybe Message +lastMsg = withFirstMessage id + + +-- ---------------------------------------------------------------------- +-- Flagged messages + + +loadFlaggedMessages :: Seq.Seq Preference -> ChatState -> IO () +loadFlaggedMessages prefs st = doAsyncWithIO Normal st $ do + return $ sequence_ [ updateMessageFlag (flaggedPostId fp) True + | Just fp <- F.toList (fmap preferenceToFlaggedPost 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^.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 () diff --git a/src/State/PostListOverlay.hs b/src/State/PostListOverlay.hs --- a/src/State/PostListOverlay.hs +++ b/src/State/PostListOverlay.hs @@ -1,5 +1,6 @@ module State.PostListOverlay where +import Control.Monad import Data.Text (Text) import Lens.Micro.Platform import Network.Mattermost.Endpoints @@ -15,15 +16,15 @@ enterPostListMode :: PostListContents -> Messages -> MH () enterPostListMode contents msgs = do csPostListOverlay.postListPosts .= msgs - csPostListOverlay.postListSelected .= getLatestPostId msgs - csMode .= PostListOverlay contents + csPostListOverlay.postListSelected .= join ((^.mPostId) <$> getLatestPostMsg msgs) + setMode $ PostListOverlay contents -- | Clear out the state of a PostListOverlay exitPostListMode :: MH () exitPostListMode = do csPostListOverlay.postListPosts .= mempty csPostListOverlay.postListSelected .= Nothing - csMode .= Main + setMode Main -- | Create a PostListOverlay with flagged messages from the server. enterFlaggedPostListMode :: MH () diff --git a/src/State/Setup.hs b/src/State/Setup.hs --- a/src/State/Setup.hs +++ b/src/State/Setup.hs @@ -32,8 +32,7 @@ import InputHistory import Login import LastRunState -import State (updateMessageFlag) -import State.Common +import State.Messages import TeamSelect import Themes import TimeUtils (lookupLocalTimeZone) @@ -42,13 +41,6 @@ import Types.Channels import qualified Zipper as Z -loadFlaggedMessages :: Seq.Seq Preference -> ChatState -> IO () -loadFlaggedMessages prefs st = doAsyncWithIO Normal st $ do - return $ sequence_ [ updateMessageFlag (flaggedPostId fp) True - | Just fp <- F.toList (fmap preferenceToFlaggedPost prefs) - , flaggedPostStatus fp - ] - incompleteCredentials :: Config -> ConnectionInfo incompleteCredentials config = ConnectionInfo hStr (configPort config) uStr pStr where @@ -203,8 +195,7 @@ -- Since the only channel we are dealing with is by construction the -- last channel, we don't have to consider other cases here: msgs <- forM (F.toList chans) $ \c -> do - let cChannel = makeClientChannel c & ccInfo.cdCurrentState .~ state - state = ChanInitialSelect + cChannel <- makeClientChannel c return (getId c, cChannel) tz <- lookupLocalTimeZone @@ -242,7 +233,16 @@ chanIds = [ (chanNames ^. cnToChanId) HM.! i | i <- chanNames ^. cnChans ] chanZip = Z.fromList chanIds - st = newState cr chanZip myUser myTeam tz hist spResult + startupState = + StartupStateInfo { startupStateResources = cr + , startupStateChannelZipper = chanZip + , startupStateConnectedUser = myUser + , startupStateTeam = myTeam + , startupStateTimeZone = tz + , startupStateInitialHistory = hist + , startupStateSpellChecker = spResult + } + st = newState startupState & csChannels %~ flip (foldr (uncurry addChannel)) msgs & csNames .~ chanNames diff --git a/src/Themes.hs b/src/Themes.hs --- a/src/Themes.hs +++ b/src/Themes.hs @@ -4,7 +4,6 @@ , defaultTheme , internalThemes - , attrNameForTokenType , lookupTheme , themeDocs @@ -26,6 +25,7 @@ , clientStrongAttr , dateTransitionAttr , newMessageTransitionAttr + , gapMessageAttr , errorMessageAttr , helpAttr , helpEmphAttr @@ -61,6 +61,9 @@ import Brick import Brick.Themes import Brick.Widgets.List +import Brick.Widgets.Skylighting ( attrNameForTokenType, attrMappingsForStyle + , highlightedCodeBlockAttr + ) import qualified Data.Text as T import qualified Skylighting as Sky import Skylighting (TokenType(..)) @@ -164,6 +167,9 @@ errorMessageAttr :: AttrName errorMessageAttr = "errorMessage" +gapMessageAttr :: AttrName +gapMessageAttr = "gapMessage" + misspellingAttr :: AttrName misspellingAttr = "misspelling" @@ -228,6 +234,7 @@ , (dateTransitionAttr, fg green) , (newMessageTransitionAttr, black `on` yellow) , (errorMessageAttr, fg red) + , (gapMessageAttr, fg red) , (helpAttr, black `on` cyan) , (helpEmphAttr, fg white) , (channelSelectMatchAttr, black `on` magenta) @@ -247,7 +254,7 @@ , (editedRecentlyMarkingAttr, black `on` yellow) ] <> ((\(i, a) -> (usernameAttr i, a)) <$> zip [0..] usernameColors) <> - (themeEntriesForStyle sty) + (filter skipBaseCodeblockAttr $ attrMappingsForStyle sty) darkAttrs :: [(AttrName, Attr)] darkAttrs = @@ -270,6 +277,7 @@ , (dateTransitionAttr, fg green) , (newMessageTransitionAttr, fg yellow `withStyle` bold) , (errorMessageAttr, fg red) + , (gapMessageAttr, black `on` yellow) , (helpAttr, black `on` cyan) , (helpEmphAttr, fg white) , (channelSelectMatchAttr, black `on` magenta) @@ -289,8 +297,11 @@ , (editedRecentlyMarkingAttr, black `on` yellow) ] <> ((\(i, a) -> (usernameAttr i, a)) <$> zip [0..] usernameColors) <> - (themeEntriesForStyle sty) + (filter skipBaseCodeblockAttr $ attrMappingsForStyle sty) +skipBaseCodeblockAttr :: (AttrName, Attr) -> Bool +skipBaseCodeblockAttr = ((/= highlightedCodeBlockAttr) . fst) + darkColorTheme :: InternalTheme darkColorTheme = InternalTheme name theme where @@ -324,72 +335,6 @@ -- Functions for dealing with Skylighting styles -baseHighlightedCodeBlockAttr :: AttrName -baseHighlightedCodeBlockAttr = "highlightedCodeBlock" - -attrNameForTokenType :: TokenType -> AttrName -attrNameForTokenType ty = baseHighlightedCodeBlockAttr <> (attrName s) - where - s = case ty of - KeywordTok -> "keyword" - DataTypeTok -> "dataType" - DecValTok -> "declaration" - BaseNTok -> "baseN" - FloatTok -> "float" - ConstantTok -> "constant" - CharTok -> "char" - SpecialCharTok -> "specialChar" - StringTok -> "string" - VerbatimStringTok -> "verbatimString" - SpecialStringTok -> "specialString" - ImportTok -> "import" - CommentTok -> "comment" - DocumentationTok -> "documentation" - AnnotationTok -> "annotation" - CommentVarTok -> "comment" - OtherTok -> "other" - FunctionTok -> "function" - VariableTok -> "variable" - ControlFlowTok -> "controlFlow" - OperatorTok -> "operator" - BuiltInTok -> "builtIn" - ExtensionTok -> "extension" - PreprocessorTok -> "preprocessor" - AttributeTok -> "attribute" - RegionMarkerTok -> "regionMarker" - InformationTok -> "information" - WarningTok -> "warning" - AlertTok -> "alert" - ErrorTok -> "error" - NormalTok -> "normal" - -themeEntriesForStyle :: Sky.Style -> [(AttrName, Attr)] -themeEntriesForStyle sty = - mkTokenTypeEntry <$> Sky.tokenStyles sty - -baseAttrFromPair :: (Maybe Sky.Color, Maybe Sky.Color) -> Attr -baseAttrFromPair (mf, mb) = - case (mf, mb) of - (Nothing, Nothing) -> defAttr - (Just f, Nothing) -> fg (tokenColorToVtyColor f) - (Nothing, Just b) -> bg (tokenColorToVtyColor b) - (Just f, Just b) -> (tokenColorToVtyColor f) `on` - (tokenColorToVtyColor b) - -tokenColorToVtyColor :: Sky.Color -> Color -tokenColorToVtyColor (Sky.RGB r g b) = rgbColor r g b - -mkTokenTypeEntry :: (Sky.TokenType, Sky.TokenStyle) -> (AttrName, Attr) -mkTokenTypeEntry (ty, tSty) = - let a = setStyle baseAttr - baseAttr = baseAttrFromPair (Sky.tokenColor tSty, Sky.tokenBackground tSty) - setStyle = - if Sky.tokenBold tSty then flip withStyle bold else id . - if Sky.tokenItalic tSty then flip withStyle standout else id . - if Sky.tokenUnderline tSty then flip withStyle underline else id - - in (attrNameForTokenType ty, a) - attrNameDescription :: ThemeDocumentation -> AttrName -> Maybe T.Text attrNameDescription td an = M.lookup an (themeDescriptions td) @@ -449,6 +394,9 @@ , ( errorMessageAttr , "Matterhorn error messages" ) + , ( gapMessageAttr + , "Matterhorn message gap information" + ) , ( helpAttr , "The help screen text" ) @@ -499,6 +447,9 @@ ) , ( editedRecentlyMarkingAttr , "The 'edited' marking that appears on newly-edited messages" + ) + , ( highlightedCodeBlockAttr + , "The base attribute for syntax-highlighted code blocks" ) , ( attrNameForTokenType KeywordTok , "Syntax highlighting: Keyword" diff --git a/src/Types.hs b/src/Types.hs --- a/src/Types.hs +++ b/src/Types.hs @@ -12,6 +12,7 @@ , MHEvent(..) , Name(..) , ChannelSelectMatch(..) + , StartupStateInfo(..) , ConnectionInfo(..) , ciHostname , ciPort @@ -63,7 +64,6 @@ , csRecentChannel , csPostListOverlay , csMyTeam - , csMode , csMessageSelect , csJoinChannelList , csConnectionStatus @@ -76,6 +76,10 @@ , csMe , csEditState , timeZone + , whenMode + , setMode + , setMode' + , appMode , ChatEditState , emptyEditState @@ -121,6 +125,7 @@ , mh , mhSuspendAndResume , mhHandleEventLensed + , gets , requestQuit , clientPostToMessage @@ -159,6 +164,8 @@ import Control.Concurrent.MVar (MVar) import Control.Exception (SomeException) import qualified Control.Monad.State as St +import Control.Monad.State (gets) +import Control.Monad (when) import qualified Data.Foldable as F import qualified Data.Sequence as Seq import Data.HashMap.Strict (HashMap) @@ -169,8 +176,8 @@ import Data.Maybe import Data.Monoid import qualified Data.Set as Set -import Lens.Micro.Platform ( at, makeLenses, lens, (&), (^.), (%~), (.~), (^?!) - , _Just, Traversal', preuse, (^..), folded, to ) +import Lens.Micro.Platform ( at, makeLenses, lens, (&), (^.), (%~), (.~), (^?!), (.=) + , use, _Just, Traversal', preuse, (^..), folded, to ) import Network.Mattermost (ConnectionData) import Network.Mattermost.Exceptions import Network.Mattermost.Lenses @@ -323,7 +330,7 @@ -- | For representing links to things in the 'open links' view data LinkChoice = LinkChoice { _linkTime :: ServerTime - , _linkUser :: T.Text + , _linkUser :: UserRef , _linkName :: T.Text , _linkURL :: T.Text , _linkFileId :: Maybe FileId @@ -503,15 +510,18 @@ , _csPostListOverlay :: PostListOverlayState } -newState :: ChatResources - -> Zipper ChannelId - -> User - -> Team - -> TimeZoneSeries - -> InputHistory - -> Maybe (Aspell, IO ()) - -> ChatState -newState rs i u m tz hist sp = ChatState +data StartupStateInfo = + StartupStateInfo { startupStateResources :: ChatResources + , startupStateChannelZipper :: Zipper ChannelId + , startupStateConnectedUser :: User + , startupStateTeam :: Team + , startupStateTimeZone :: TimeZoneSeries + , startupStateInitialHistory :: InputHistory + , startupStateSpellChecker :: Maybe (Aspell, IO ()) + } + +newState :: StartupStateInfo -> ChatState +newState (StartupStateInfo rs i u m tz hist sp) = ChatState { _csResources = rs , _csFocus = i , _csMe = u @@ -655,6 +665,20 @@ makeLenses ''PostListOverlayState makeLenses ''ChannelSelectState +whenMode :: Mode -> MH () -> MH () +whenMode m act = do + curMode <- use csMode + when (curMode == m) act + +setMode :: Mode -> MH () +setMode = (csMode .=) + +setMode' :: Mode -> ChatState -> ChatState +setMode' m st = st & csMode .~ m + +appMode :: ChatState -> Mode +appMode = _csMode + resetSpellCheckTimer :: ChatEditState -> IO () resetSpellCheckTimer s = case s^.cedSpellChecker of @@ -687,7 +711,7 @@ -- ** 'ChatState' Helper Functions isMine :: ChatState -> Message -> Bool -isMine st msg = (Just $ st^.csMe.userUsernameL) == msg^.mUserName +isMine st msg = (UserI $ st^.csMe.userIdL) == msg^.mUser getMessageForPostId :: ChatState -> PostId -> Maybe Message getMessageForPostId st pId = st^.csPostMap.at(pId) @@ -701,13 +725,12 @@ getUsernameForUserId :: ChatState -> UserId -> Maybe T.Text getUsernameForUserId st uId = _uiName <$> findUserById uId (st^.csUsers) -clientPostToMessage :: ChatState -> ClientPost -> Message -clientPostToMessage st cp = Message +clientPostToMessage :: ClientPost -> Message +clientPostToMessage cp = Message { _mText = cp^.cpText - , _mUserName = case cp^.cpUserOverride of - Just n - | cp^.cpType == NormalPost -> Just (n <> "[BOT]") - _ -> getUsernameForUserId st =<< cp^.cpUser + , _mUser = case cp^.cpUserOverride of + Just n | cp^.cpType == NormalPost -> UserOverride (n <> "[BOT]") + _ -> maybe NoUser UserI $ cp^.cpUser , _mDate = cp^.cpDate , _mType = CP $ cp^.cpType , _mPending = cp^.cpPending diff --git a/src/Types/Channels.hs b/src/Types/Channels.hs --- a/src/Types/Channels.hs +++ b/src/Types/Channels.hs @@ -8,17 +8,16 @@ ( ClientChannel(..) , ChannelContents(..) , ChannelInfo(..) - , ChannelState(..) , ClientChannels -- constructor remains internal , NewMessageIndicator(..) -- * Lenses created for accessing ClientChannel fields , ccContents, ccInfo -- * Lenses created for accessing ChannelInfo fields , cdViewed, cdNewMessageIndicator, cdEditedMessageThreshold, cdUpdated - , cdName, cdHeader, cdPurpose, cdType, cdCurrentState + , cdName, cdHeader, cdPurpose, cdType , cdMentionCount, cdTypingUsers -- * Lenses created for accessing ChannelContents fields - , cdMessages + , cdMessages, cdFetchPending -- * Creating ClientChannel objects , makeClientChannel -- * Managing ClientChannel collections @@ -29,11 +28,6 @@ -- * Creating ChannelInfo objects , channelInfoFromChannelWithData -- * Channel State management - , initialChannelState - , loadingChannelContentState - , isPendingState - , pendingChannelState - , quiescentChannelState , clearNewMessageIndicator , clearEditedThreshold , adjustUpdated @@ -46,9 +40,11 @@ , canLeaveChannel , preferredChannelName , isTownSquare + , channelDeleted ) where +import Control.Monad.IO.Class (MonadIO) import qualified Data.HashMap.Strict as HM import qualified Data.Text as T import Data.Time.Clock (UTCTime) @@ -65,8 +61,9 @@ , ServerTime , emptyChannelNotifyProps ) -import Types.Messages (Messages, noMessages) -import Types.Users (TypingUsers, noTypingUsers, addTypingUser) +import Types.Messages (Messages, noMessages, addMessage, clientMessageToMessage) +import Types.Posts (ClientMessageType(UnknownGap), newClientMessage) +import Types.Users (TypingUsers, noTypingUsers, addTypingUser) -- * Channel representations @@ -103,7 +100,6 @@ , _cdHeader = chan^.channelHeaderL , _cdPurpose = chan^.channelPurposeL , _cdType = chan^.channelTypeL - , _cdCurrentState = initialChannelState , _cdNotifyProps = emptyChannelNotifyProps , _cdTypingUsers = noTypingUsers } @@ -129,96 +125,22 @@ -- 'Message' values data ChannelContents = ChannelContents { _cdMessages :: Messages + , _cdFetchPending :: Bool } --- | An initial empty 'ChannelContents' value -emptyChannelContents :: ChannelContents -emptyChannelContents = ChannelContents - { _cdMessages = noMessages - } +-- | An initial empty 'ChannelContents' value. This also contains an +-- UnknownGap, which is a signal that causes actual content fetching. +-- The initial Gap's timestamp is the local client time, but +-- subsequent fetches will synchronize with the server (and eventually +-- eliminate this Gap as well). +emptyChannelContents :: MonadIO m => m ChannelContents +emptyChannelContents = do + gapMsg <- clientMessageToMessage <$> newClientMessage UnknownGap "--Fetching messages--" + return $ ChannelContents { _cdMessages = addMessage gapMsg noMessages + , _cdFetchPending = False + } ------------------------------------------------------------------------- --- * Channel State management - --- | The 'ChannelState' represents our internal state --- of the channel with respect to our knowledge (or --- lack thereof) about the server's information --- about the channel. -data ChannelState - = ChanGettingInfo -- ^ (Re-) fetching for an unloaded channel - | ChanUnloaded -- ^ Only have channel metadata - | ChanGettingPosts -- ^ (Re-) fetching for a loaded channel - | ChanInitialSelect -- ^ Initially selected channel, but not contents yet - | ChanLoaded -- ^ Have channel metadata and contents - deriving (Eq, Show) - --- The ChannelState may be affected by background operations (see --- asyncIO), so state transitions may be suggested by the completion --- of those asynchronous operations but they should be reconciled with --- any other asynchronous (or foreground) state updates. --- --- To facilitate this, the ChannelState is a member of Ord and Enum, --- with the intention that states generally transition to higher state --- values (indicating more knowledge/completeness) and not downwards, --- allowing the use of `max` and `pred` and `succ` below for managing --- state changes. The `Ord` and `Enum` membership is merely for local --- convenience: all state management should be handled by the methods --- below so more detailed methods can be used instead of the Ord and --- Enum instances without impact to external code. - --- | Specifies the initial state for created ClientChannel objects. -initialChannelState :: ChannelState -initialChannelState = ChanUnloaded - --- | The state to use to indicate that channel content (i.e., --- messages) are being loaded (possibly asynchronously). In contrast --- to the `pendingChannelState` function, this function is used when --- the channel is transitioning from only having the metadata --- information to having full content information. -loadingChannelContentState :: ChannelState -loadingChannelContentState = ChanGettingPosts - --- | The pendingChannelState specifies the new ChannelState to --- represent an active fetch of information for a channel, given the --- channel's current state. This is used when the existing --- information is being refreshed. The return is a tuple of the new --- state and a function to call after the async operation has finished --- with the ChannelState at that time and which will return the new --- state that should be set on that completion. -pendingChannelState :: ChannelState -> (ChannelState, - (ChannelState -> ChannelState)) -pendingChannelState ChanGettingInfo = (ChanGettingInfo, id) -pendingChannelState ChanGettingPosts = (ChanGettingPosts, id) -pendingChannelState ChanUnloaded = (ChanGettingInfo, quiescentChannelState ChanUnloaded) -pendingChannelState ChanLoaded = (ChanGettingPosts, quiescentChannelState ChanLoaded) -pendingChannelState ChanInitialSelect = (ChanGettingPosts, quiescentChannelState ChanInitialSelect) - --- | The completionChannelState specifies the new ChannelState upon --- completion of an activity. The activity is represented by the --- first argument, which is the pendingState. The channel may have --- been updated in the interim by other activities as well, so the --- currentState is also provided. This function determines the proper --- new state of the channel based on the action and current state. In --- the event that multiple update operations are performed at the same --- time, the state should always reach higher resting states. -quiescentChannelState :: ChannelState -> ChannelState -> ChannelState -quiescentChannelState targetState currentState = - if isPendingState targetState - then currentState - else case (currentState, targetState) of - (ChanLoaded, ChanUnloaded) -> ChanLoaded - (ChanGettingPosts, ChanUnloaded) -> ChanGettingPosts - (ChanInitialSelect, ChanUnloaded) -> ChanInitialSelect - (_, t) -> t - --- | Returns true if the channel's state is one where there is a --- pending asynchronous update already scheduled. -isPendingState :: ChannelState -> Bool -isPendingState cstate = cstate `elem` [ ChanGettingPosts - , ChanGettingInfo - ] - ------------------------------------------------------------------------ -- | The 'ChannelInfo' record represents metadata @@ -242,8 +164,6 @@ -- ^ The stated purpose of the channel , _cdType :: Type -- ^ The type of a channel: public, private, or DM - , _cdCurrentState :: ChannelState - -- ^ The current state of the channel , _cdNotifyProps :: ChannelNotifyProps -- ^ The user's notification settings for this channel , _cdTypingUsers :: TypingUsers @@ -264,9 +184,10 @@ -- ** Miscellaneous channel operations -makeClientChannel :: Channel -> ClientChannel -makeClientChannel nc = ClientChannel - { _ccContents = emptyChannelContents +makeClientChannel :: (MonadIO m) => Channel -> m ClientChannel +makeClientChannel nc = emptyChannelContents >>= \contents -> + return ClientChannel + { _ccContents = contents , _ccInfo = initialChannelInfo nc } @@ -325,6 +246,11 @@ filteredChannels f cc = AllChannels . HM.fromList . filter f $ cc^.ofChans.to HM.toList +------------------------------------------------------------------------ + +-- * Channel State management + + -- | Add user to the list of users in this channel who are currently typing. addChannelTypingUser :: UserId -> UTCTime -> ClientChannel -> ClientChannel addChannelTypingUser uId ts = ccInfo.cdTypingUsers %~ (addTypingUser uId ts) @@ -377,3 +303,6 @@ -- changed its display name. isTownSquare :: Channel -> Bool isTownSquare c = c^.channelNameL == "town-square" + +channelDeleted :: Channel -> Bool +channelDeleted c = c^.channelDeleteAtL > c^.channelCreateAtL diff --git a/src/Types/DirectionalSeq.hs b/src/Types/DirectionalSeq.hs --- a/src/Types/DirectionalSeq.hs +++ b/src/Types/DirectionalSeq.hs @@ -12,7 +12,7 @@ module Types.DirectionalSeq where -import Data.Monoid () +import Data.Monoid import qualified Data.Sequence as Seq @@ -34,3 +34,57 @@ -> DirectionalSeq dir a -> DirectionalSeq dir b onDirectedSeq f = DSeq . f . dseq +-- | Uses a start-predicate and and end-predicate to +-- identify (the first matching) subset that is delineated by +-- start-predicate and end-predicate (inclusive). It will then call +-- the passed operation function on the subset messages to get back a +-- (possibly modified) set of messages, along with an extracted value. +-- The 'onDirSeqSubset' function will replace the original subset of +-- messages with the set returned by the operation function and return +-- the resulting message list along with the extracted value. + +onDirSeqSubset :: SeqDirection dir => + (e -> Bool) -> (e -> Bool) + -> (DirectionalSeq dir e -> (DirectionalSeq dir e, a)) + -> DirectionalSeq dir e + -> (DirectionalSeq dir e, a) +onDirSeqSubset startPred endPred op entries = + let ml = dseq entries + (bl, ml1) = Seq.breakl startPred ml + (ml2, el) = Seq.breakl endPred ml1 + -- move match from start of el to end of ml2 + (ml2', el') = if not (Seq.null el) + then (ml2 <> Seq.take 1 el, Seq.drop 1 el) + else (ml2, el) + (ml3, rval) = op $ DSeq ml2' + in (DSeq bl <> ml3 <> DSeq el', rval) + +-- | dirSeqBreakl splits the DirectionalSeq into a tuple where the +-- first element is the (possibly empty) DirectionalSeq of all +-- elements from the start for which the predicate returns false; the +-- second tuple element is the remainder of the list, starting with +-- the first element for which the predicate matched. +dirSeqBreakl :: SeqDirection dir => + (e -> Bool) -> DirectionalSeq dir e + -> (DirectionalSeq dir e, DirectionalSeq dir e) +dirSeqBreakl isMatch entries = + let (removed, remaining) = Seq.breakl isMatch $ dseq entries + in (DSeq removed, DSeq remaining) + +-- | dirSeqPartition splits the DirectionalSeq into a tuple of two +-- DirectionalSeq elements: the first contains all elements for which +-- the predicate is true and the second contains all elements for +-- which the predicate is false. +dirSeqPartition :: SeqDirection dir => + (e -> Bool) -> DirectionalSeq dir e + -> (DirectionalSeq dir e, DirectionalSeq dir e) +dirSeqPartition isMatch entries = + let (match, nomatch) = Seq.partition isMatch $ dseq entries + in (DSeq match, DSeq nomatch) + + +withDirSeqHead :: SeqDirection dir => (e -> r) -> DirectionalSeq dir e -> Maybe r +withDirSeqHead op entries = + case Seq.viewl (dseq entries) of + Seq.EmptyL -> Nothing + e Seq.:< _ -> Just $ op e diff --git a/src/Types/Messages.hs b/src/Types/Messages.hs --- a/src/Types/Messages.hs +++ b/src/Types/Messages.hs @@ -38,11 +38,12 @@ module Types.Messages ( -- * Message and operations on a single Message Message(..) - , isDeletable, isReplyable, isEditable, isReplyTo - , mText, mUserName, mDate, mType, mPending, mDeleted + , isDeletable, isReplyable, isEditable, isReplyTo, isGap + , mText, mUser, mDate, mType, mPending, mDeleted , mAttachments, mInReplyToMsg, mPostId, mReactions, mFlagged , mOriginalPost, mChannelId , MessageType(..) + , UserRef(..) , ReplyState(..) , clientMessageToMessage , newMessageOfType @@ -57,24 +58,30 @@ , unreverseMessages -- * Operations on Posted Messages , splitMessages + , splitMessagesOn + , splitRetrogradeMessagesOn , findMessage , getNextPostId , getPrevPostId - , getLatestPostId + , getEarliestPostMsg + , getLatestPostMsg , findLatestUserMessage -- * Operations on any Message type , messagesAfter + , removeMatchesFromSubset + , withFirstMessage ) where import Cheapskate (Blocks) import Control.Applicative import qualified Data.Map.Strict as Map -import Data.Maybe (isJust) -import qualified Data.Sequence as Seq +import Data.Maybe (isJust, isNothing) +import Data.Sequence as Seq import qualified Data.Text as T +import Data.Tuple import Lens.Micro.Platform -import Network.Mattermost.Types (ChannelId, PostId, Post, ServerTime) +import Network.Mattermost.Types (ChannelId, PostId, Post, ServerTime, UserId) import Types.DirectionalSeq import Types.Posts @@ -85,7 +92,7 @@ -- Mattermost itself or from a client-internal source. data Message = Message { _mText :: Blocks - , _mUserName :: Maybe T.Text + , _mUser :: UserRef , _mDate :: ServerTime , _mType :: MessageType , _mPending :: Bool @@ -114,6 +121,9 @@ NotAReply -> False InReplyTo actualParentId -> actualParentId == expectedParentId +isGap :: Message -> Bool +isGap m = _mType m == C UnknownGap + -- | A 'Message' is the representation we use for storage and -- rendering, so it must be able to represent either a -- post from Mattermost or an internal message. This represents @@ -122,6 +132,12 @@ | CP ClientPostType deriving (Eq, Show) +-- | There may be no user (usually an internal message), a reference +-- to a user (by Id), or the server may have supplied a specific +-- username (often associated with bots). +data UserRef = NoUser | UserI UserId | UserOverride T.Text + deriving (Eq, Show, Ord) + -- | The 'ReplyState' of a message represents whether a message -- is a reply, and if so, to what message data ReplyState = @@ -136,7 +152,7 @@ clientMessageToMessage :: ClientMessage -> Message clientMessageToMessage cm = Message { _mText = getBlocks (cm^.cmText) - , _mUserName = Nothing + , _mUser = NoUser , _mDate = cm^.cmDate , _mType = C $ cm^.cmType , _mPending = False @@ -153,7 +169,7 @@ newMessageOfType :: T.Text -> MessageType -> ServerTime -> Message newMessageOfType text typ d = Message { _mText = getBlocks text - , _mUserName = Nothing + , _mUser = NoUser , _mDate = d , _mType = typ , _mPending = False @@ -206,11 +222,11 @@ instance MessageOps ChronologicalMessages where addMessage m ml = - case Seq.viewr (dseq ml) of - Seq.EmptyR -> DSeq $ Seq.singleton m - _ Seq.:> l -> + case viewr (dseq ml) of + EmptyR -> DSeq $ singleton m + _ :> l -> case compare (m^.mDate) (l^.mDate) of - GT -> DSeq $ dseq ml Seq.|> m + GT -> DSeq $ dseq ml |> m EQ -> if m^.mPostId == l^.mPostId && isJust (m^.mPostId) then ml else dirDateInsert m ml @@ -220,15 +236,15 @@ dirDateInsert :: Message -> ChronologicalMessages -> ChronologicalMessages dirDateInsert m = onDirectedSeq $ finalize . foldr insAfter initial where initial = (Just m, mempty) - insAfter c (Nothing, l) = (Nothing, c Seq.<| l) + insAfter c (Nothing, l) = (Nothing, c <| l) insAfter c (Just n, l) = case compare (n^.mDate) (c^.mDate) of - GT -> (Nothing, c Seq.<| (n Seq.<| l)) + GT -> (Nothing, c <| (n <| l)) EQ -> if n^.mPostId == c^.mPostId && isJust (c^.mPostId) - then (Nothing, c Seq.<| l) - else (Just n, c Seq.<| l) - LT -> (Just n, c Seq.<| l) - finalize (Just n, l) = n Seq.<| l + then (Nothing, c <| l) + else (Just n, c <| l) + LT -> (Just n, c <| l) + finalize (Just n, l) = n <| l finalize (_, l) = l noMessages :: Messages @@ -242,6 +258,38 @@ unreverseMessages :: RetrogradeMessages -> Messages unreverseMessages = DSeq . Seq.reverse . dseq +-- | Splits the message list at first message where the specified +-- predicate returns true. The result is the message where the split +-- occurred, followed by the messages preceeding the split point (in +-- retrograde order) and the messages following the split point). If +-- the predicate never matches a message before reaching the end of +-- the list, then the matched message is None and all of the messages +-- are in the first (retrograde) collection of of messages. +splitMessagesOn :: (Message -> Bool) + -> Messages + -> (Maybe Message, (RetrogradeMessages, Messages)) +splitMessagesOn = splitMsgSeqOn + +-- | Similar to 'splitMessagesOn', but taking RetrogradeMessages as input. +splitRetrogradeMessagesOn :: (Message -> Bool) + -> RetrogradeMessages + -> (Maybe Message, (Messages, RetrogradeMessages)) +splitRetrogradeMessagesOn = splitMsgSeqOn + +-- n.b., the splitMessagesOn and splitRetrogradeMessagesOn could be +-- unified into the following, but that will require TypeFamilies or +-- similar to relate d and r SeqDirection types. For now, it's +-- simplier to just have two API endpoints. +splitMsgSeqOn :: (SeqDirection d, SeqDirection r) => + (Message -> Bool) + -> DirectionalSeq d Message + -> (Maybe Message, (DirectionalSeq r Message, DirectionalSeq d Message)) +splitMsgSeqOn f msgs = + let (removed, remaining) = dirSeqBreakl f msgs + devomer = DSeq $ Seq.reverse $ dseq removed + in (withDirSeqHead id remaining, (devomer, onDirectedSeq (Seq.drop 1) remaining)) + + -- ---------------------------------------------------------------------- -- * Operations on Posted Messages @@ -256,27 +304,14 @@ splitMessages :: Maybe PostId -> Messages -> (Maybe Message, (RetrogradeMessages, Messages)) -splitMessages Nothing msgs = - (Nothing, (DSeq $ Seq.reverse $ dseq msgs, noMessages)) -splitMessages pid msgs = - -- n.b. searches from the end as that is usually where the message - -- is more likely to be found. There is usually < 1000 messages - -- total, so this does not need hyper efficiency. - case Seq.viewr (dseq msgs) of - Seq.EmptyR -> (Nothing, (reverseMessages noMessages, noMessages)) - ms Seq.:> m -> if m^.mPostId == pid - then (Just m, (DSeq $ Seq.reverse ms, noMessages)) - else let (a, (b,c)) = splitMessages pid $ DSeq ms - in case a of - Nothing -> (a, (DSeq $ m Seq.<| (dseq b), c)) - Just _ -> (a, (b, DSeq $ (dseq c) Seq.|> m)) +splitMessages pid msgs = splitMessagesOn (\m -> isJust pid && m^.mPostId == pid) 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 = - Seq.findIndexR (\m -> m^.mPostId == Just pid) (dseq msgs) + findIndexR (\m -> m^.mPostId == Just pid) (dseq msgs) >>= Just . Seq.index (dseq msgs) -- | Look forward for the first Message that corresponds to a user @@ -301,7 +336,7 @@ -> Messages -> Maybe PostId getRelPostId folD jp = case jp of - Nothing -> getLatestPostId + Nothing -> \msgs -> (getLatestPostMsg msgs >>= _mPostId) 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 @@ -310,33 +345,83 @@ -- | Find the most recent message that is a Post (as opposed to a -- local message) (if any). -getLatestPostId :: Messages -> Maybe PostId -getLatestPostId msgs = - Seq.findIndexR valid (dseq msgs) - >>= _mPostId <$> Seq.index (dseq msgs) - where valid m = not (m^.mDeleted) && isJust (m^.mPostId) +getLatestPostMsg :: Messages -> Maybe Message +getLatestPostMsg msgs = + case viewr $ dropWhileR (not . validUserMessage) (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 +getEarliestPostMsg msgs = + case viewl $ dropWhileL (not . validUserMessage) (dseq msgs) of + EmptyL -> Nothing + m :< _ -> Just m + + -- | Find the most recent message that is a message posted by a user -- that matches the test (if any), skipping local client messages and -- any user event that is not a message (i.e. find a normal message or -- an emote). findLatestUserMessage :: (Message -> Bool) -> Messages -> Maybe Message -findLatestUserMessage f msgs = - case getLatestPostId msgs of - Nothing -> Nothing - Just pid -> findUserMessageFrom pid msgs - where findUserMessageFrom p ms = - let Just msg = findMessage p ms - in if f msg - then Just msg - else case getPrevPostId (msg^.mPostId) msgs of - Nothing -> Nothing - Just p' -> findUserMessageFrom p' msgs +findLatestUserMessage f ml = + case viewr $ dropWhileR (\m -> not (validUserMessage m && f m)) $ dseq ml of + EmptyR -> Nothing + _ :> m -> Just m + +validUserMessage :: Message -> Bool +validUserMessage m = isJust (m^.mPostId) && not (m^.mDeleted) + -- ---------------------------------------------------------------------- -- * Operations on any Message type -- | Return all messages that were posted after the specified date/time. messagesAfter :: ServerTime -> Messages -> Messages -messagesAfter viewTime = onDirectedSeq $ Seq.takeWhileR (\m -> m^.mDate > viewTime) +messagesAfter viewTime = onDirectedSeq $ takeWhileR (\m -> m^.mDate > viewTime) + +-- | 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 +-- start to finish, irrespective of 'firstId' and 'lastId') and the +-- list of removed items. +-- +-- start | end | operates-on | (test) case +-- --------------------------------------------------------|------------- +-- Nothing | Nothing | entire list | C1 +-- Nothing | Just found | start --> found] | C2 +-- Nothing | Just missing | nothing [suggest invalid] | C3 +-- Just found | Nothing | [found --> end | C4 +-- Just found | Just found | [found --> found] | C5 +-- Just found | Just missing | [found --> end | C6 +-- Just missing | Nothing | nothing [suggest invalid] | C7 +-- Just missing | Just found | start --> found] | C8 +-- Just missing | Just missing | nothing [suggest invalid] | C9 +-- +-- @removeMatchesFromSubset matchPred fromId toId msgs = (remaining, removed)@ +-- +removeMatchesFromSubset :: (Message -> Bool) -> Maybe PostId -> Maybe PostId + -> Messages -> (Messages, Messages) +removeMatchesFromSubset matching firstId lastId msgs = + let knownIds = fmap (^.mPostId) 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) + (swap . dirSeqPartition matching) msgs + else if isJust lastId && lastId `elem` knownIds + then onDirSeqSubset + (const True) + (\m -> m^.mPostId == lastId) + (swap . dirSeqPartition matching) msgs + else (msgs, noMessages) + +-- | Performs an operation on the first Message, returning just the +-- result of that operation, or Nothing if there were no messages. +-- Note that the message is not necessarily a posted user message. +withFirstMessage :: SeqDirection dir => (Message -> r) -> DirectionalSeq dir Message -> Maybe r +withFirstMessage = withDirSeqHead diff --git a/src/Types/Posts.hs b/src/Types/Posts.hs --- a/src/Types/Posts.hs +++ b/src/Types/Posts.hs @@ -86,6 +86,7 @@ | Error | DateTransition | NewMessagesTransition + | UnknownGap -- ^ marks region where server may have messages unknown locally deriving (Eq, Show) -- ** 'ClientMessage' Lenses diff --git a/src/Types/Users.hs b/src/Types/Users.hs --- a/src/Types/Users.hs +++ b/src/Types/Users.hs @@ -17,7 +17,7 @@ , findUserById , findUserByName , findUserByDMChannelName - , noUsers, addUser, allUsers + , noUsers, addUser, allUsers, allUserIds , modifyUserById , getDMChannelName , userIdForDMChannel @@ -34,6 +34,7 @@ import qualified Data.HashMap.Strict as HM import Data.List (sort) import Data.Maybe (listToMaybe, maybeToList) +import qualified Data.Set as Set import qualified Data.Text as T import Data.Time (UTCTime) import Lens.Micro.Platform @@ -116,6 +117,9 @@ -- | Add a member to the existing collection of Users addUser :: UserId -> UserInfo -> Users -> Users addUser uId userinfo = AllUsers . HM.insert uId userinfo . _ofUsers + +allUserIds :: Users -> Set.Set UserId +allUserIds = Set.fromList . HM.keys . _ofUsers -- | Get a list of all known users allUsers :: Users -> [UserInfo] diff --git a/test/Message_QCA.hs b/test/Message_QCA.hs --- a/test/Message_QCA.hs +++ b/test/Message_QCA.hs @@ -14,10 +14,16 @@ genMap :: Ord key => Gen key -> Gen value -> Gen (Map key value) genMap gk gv = let kv = (,) <$> gk <*> gv in fromList <$> listOf kv +genUserRef :: Gen UserRef +genUserRef = oneof [ return NoUser + , UserI <$> genUserId + , UserOverride <$> genText + ] + genMessage :: Gen Message genMessage = Message <$> genBlocks - <*> genMaybe genText + <*> genUserRef <*> genTime <*> genMessageType <*> arbitrary @@ -39,7 +45,7 @@ genMessage__DeletedPost = Message__DeletedPost <$> (Message <$> genBlocks - <*> genMaybe genText + <*> genUserRef <*> genTime <*> genMessageType <*> arbitrary @@ -59,7 +65,7 @@ genMessage__Posted = Message__Posted <$> (Message <$> genBlocks - <*> genMaybe genText + <*> genUserRef <*> genTime <*> genMessageType <*> arbitrary diff --git a/test/test_messages.hs b/test/test_messages.hs --- a/test/test_messages.hs +++ b/test/test_messages.hs @@ -4,12 +4,14 @@ module Main where import Control.Exception -import Data.List (intercalate, sortBy) +import Data.Function (on) +import Data.List (intercalate, sortBy, sort) import qualified Data.List.UniqueUnsorted as U import qualified Data.Map as Map -import Data.Maybe (isNothing, fromJust) +import Data.Maybe (isNothing, fromJust, isJust, catMaybes) import Data.Monoid ((<>)) import qualified Data.Sequence as Seq +import qualified Data.Text as T import Data.Time.Calendar (Day(..)) import Data.Time.Clock (UTCTime(..), getCurrentTime , secondsToDiffTime) @@ -22,6 +24,7 @@ import Test.Tasty import Test.Tasty.HUnit import Test.Tasty.QuickCheck +import TimeUtils import Types.Messages import Types.Posts @@ -35,9 +38,11 @@ tests :: TestTree tests = testGroup "Messages Tests" [ createTests + , lookupTests , movementTests , reversalTests , splitTests + , removeTests , instanceTests ] @@ -62,7 +67,7 @@ tick (ServerTime (UTCTime d t)) = ServerTime $ UTCTime d $ succ t makeMsg :: ServerTime -> Maybe PostId -> Message -makeMsg t pId = Message Seq.empty Nothing t (CP NormalPost) False False Seq.empty NotAReply +makeMsg t pId = Message Seq.empty NoUser t (CP NormalPost) False False Seq.empty NotAReply pId Map.empty Nothing False Nothing makeMsgs :: [Message] -> Messages @@ -402,7 +407,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 getLatestPostId l === getLatestPostId rr + in ((^.mPostId) <$> getLatestPostMsg l) === + ((^.mPostId) <$> getLatestPostMsg rr) , testCase "reverse nothing" $ (null $ unreverseMessages $ reverseMessages noMessages) @? "reverse of empty Messages" @@ -411,6 +417,51 @@ in idlist l === reverse (idlist r) ] +lookupTests :: TestTree +lookupTests = testGroup "Lookup" + [ testProperty "getEarliestPostMsg" $ \(m1, m2, m3, m4, m5) -> + let mlist = m1 : m2 : m3 : m4 : m5 : [] + msgs = makeMsgs mlist + postIds = fmap (^.mPostId) + $ sortBy (compare `on` (^.mDate)) + $ filter (\m -> isJust (m^.mPostId) && (not $ m^.mDeleted)) mlist + firstPostId = (^.mPostId) <$> getEarliestPostMsg msgs + in if null postIds + then Nothing === firstPostId + else Just (head postIds) === firstPostId + + , testProperty "getLatestPostMsg" $ \(m1, m2, m3, m4, m5) -> + let mlist = m1 : m2 : m3 : m4 : m5 : [] + msgs = makeMsgs mlist + postIds = fmap (^.mPostId) + $ sortBy (compare `on` (^.mDate)) + $ filter (\m -> isJust (m^.mPostId) && (not $ m^.mDeleted)) mlist + lastPostId = (^.mPostId) <$> 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) + <> "\n postIds:" <> show postIds) ( + if null postIds + then Nothing === lastPostId + else Just (last postIds) === lastPostId) + + , testProperty "findLatestUserMessage" $ \(m1, m2, m3, m4, m5) -> + let mlist = m1 : m2 : m3 : m4 : m5 : [] + msgs = makeMsgs mlist + postIds = fmap (^.mPostId) + $ 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 + 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) + <> "\n postIds:" <> show postIds) ( + if null postIds + then Nothing === lastPostId + else Just (last postIds) === lastPostId .&&. Just (head postIds) === firstPostId) + ] + splitTests :: TestTree splitTests = testGroup "Split" [ testCase "split nothing on empty" $ @@ -547,6 +598,282 @@ idlist [y, z] == idlist after ] + +removeTests :: TestTree +removeTests = adjustOption (\(QuickCheckMaxRatio n) -> QuickCheckMaxRatio (n*10)) $ + testGroup "Remove" + [ testProperty "remove on empty" $ \(id1, id2) -> + let (remaining, removed) = removeMatchesFromSubset (const True) id1 id2 noMessages + in counterexample "got something from nothing" $ null remaining && null removed + + , testProperty "remove range not found (C9)" $ \(id1, id2, msglist) -> + let msgs = makeMsgs msglist + ids = idlist msgs + (remaining, removed) = removeMatchesFromSubset (const True) (Just id1) (Just id2) msgs + in (not $ Just id1 `elem` ids || Just id2 `elem` ids) ==> + counterexample "got something from invalid range" $ + null removed && length remaining == length ids + + , testProperty "remove first in range (C6)" $ \(id1, id2, msglist) -> + let msgs = makeMsgs msglist + ids = idlist msgs + (remaining, removed) = removeMatchesFromSubset (const True) (Just id1) (Just id2) msgs + in Just id1 `elem` ids && (not $ Just id2 `elem` ids) ==> + counterexample ("with idlist " <> show ids <> + " remove id1=" <> show id1 <> + " should be in " <> show (idlist removed) <> + " but not id2=" <> show id2 <> + " and remaining=" <> show (idlist remaining)) $ + (not $ null removed) && + (length remaining /= length ids) && + Just id1 `elem` idlist removed && + (not $ Just id1 `elem` idlist remaining) + + , testProperty "remove nothing first in range" $ \(id1, id2, msglist) -> + let msgs = makeMsgs msglist + ids = idlist msgs + (remaining, removed) = removeMatchesFromSubset (const False) (Just id1) (Just id2) msgs + in Just id1 `elem` ids && (not $ Just id2 `elem` ids) ==> + counterexample ("with idlist " <> show ids <> + " remove id1=" <> show id1 <> + " should be in " <> show (idlist removed) <> + " but not id2=" <> show id2 <> + " and remaining=" <> show (idlist remaining)) $ + (idlist remaining == ids && null removed) + + , testCase "remove only as last" $ + let (remaining, removed) = removeMatchesFromSubset (const True) (Just id1) (Just id2) msgs + id1 = fromId $ Id "id1" + id2 = fromId $ Id "id2" + msgs = makeMsgs [makeMsg (ServerTime originTime) (Just id2)] + in null remaining && length removed == 1 @? "removed" + + , testProperty "remove last in range (C8)" $ \(idx2, msg, msglist) -> + let msgs = makeMsgs $ msg : msglist + ids = idlist msgs + id2 = ids !! idx2' + id1 = PI $ Id $ T.intercalate "-" $ map (unId . unPI) $ catMaybes ids + idx2' = abs idx2 `mod` length ids + (remaining, removed) = removeMatchesFromSubset (const True) (Just id1) id2 msgs + in (isJust id2) && uniqueIds msgs ==> + counterexample ("with idlist " <> show ids <> + " remove id2=" <> show id2 <> + " should be in " <> show (idlist removed) <> + " but not id1=" <> show id1 <> + " and remaining=" <> show (idlist remaining) + ) $ + (not $ null removed) && + (length remaining /= length ids) && + id2 `elem` idlist removed && + (not $ id2 `elem` idlist remaining) + + , testProperty "remove sub range (C5)" $ \(m1, m2, m3, m4, m5, idx1, idx2) -> + let msgs = makeMsgs $ m1 : m2 : m3 : m4 : m5 : [] + ids = idlist msgs + + (ids', postIds) = splitAt (idx2' + 1) ids + (preIds, matchIds) = splitAt idx1' ids' + id1 = head matchIds + id2 = last matchIds + + idxl = sort $ map (\v -> abs v `mod` 5) [idx1, idx2] + idx1' = head idxl + idx2' = last idxl + + (remaining, removed) = removeMatchesFromSubset (const True) id1 id2 msgs + in uniqueIds msgs && isJust id1 && isJust id2 ==> + counterexample ("with idlist " <> show (idlist msgs) <> + "\n idx1=" <> show idx1' <> + "\n idx2=" <> show idx2' <> + "\n extracts=" <> show (idlist removed) <> + "\n matching=" <> show matchIds <> + "\n and leaves remaining=" <> show (idlist remaining) <> + "\n from " <> show preIds <> " and " <> show postIds + ) $ + (idlist remaining == (preIds <> postIds) && + idlist removed == matchIds) + + , testProperty "remove nothing sub range" $ \(m1, m2, m3, m4, m5, idx1, idx2) -> + let msgs = makeMsgs $ m1 : m2 : m3 : m4 : m5 : [] + ids = idlist msgs + + (ids', postIds) = splitAt (idx2' + 1) ids + (preIds, matchIds) = splitAt idx1' ids' + id1 = head matchIds + id2 = last matchIds + + idxl = sort $ map (\v -> abs v `mod` 5) [idx1, idx2] + idx1' = head idxl + idx2' = last idxl + + (remaining, removed) = removeMatchesFromSubset (const False) id1 id2 msgs + in uniqueIds msgs && isJust id1 && isJust id2 ==> + counterexample ("with idlist " <> show (idlist msgs) <> + "\n idx1=" <> show idx1' <> + "\n idx2=" <> show idx2' <> + "\n extracts=" <> show (idlist removed) <> + "\n matching=" <> show matchIds <> + "\n and leaves remaining=" <> show (idlist remaining) <> + "\n from " <> show preIds <> " and " <> show postIds + ) $ + (idlist remaining == ids && null removed) + + , testProperty "remove first in sub range (C5)" $ \(m1, m2, m3, m4, m5, idx1, idx2) -> + let msgs = makeMsgs $ m1 : m2 : m3 : m4 : m5 : [] + ids = idlist msgs + + (ids', _) = splitAt (idx2' + 1) ids + (_, matchIds) = splitAt idx1' ids' + id1 = head matchIds + id2 = last matchIds + + idxl = sort $ map (\v -> abs v `mod` 5) [idx1, idx2] + idx1' = head idxl + idx2' = last idxl + + (remaining, removed) = removeMatchesFromSubset (\m -> m^.mPostId == id1) id1 id2 msgs + in uniqueIds msgs && isJust id1 && isJust id2 ==> + counterexample ("with idlist " <> show (idlist msgs) <> + "\n idx1=" <> show idx1' <> + "\n idx2=" <> show idx2' <> + "\n extracts=" <> show (idlist removed) <> + "\n matching=" <> show matchIds <> + "\n and leaves remaining=" <> show (idlist remaining) + ) $ + (idlist remaining == (filter (/= id1) ids) && + idlist removed == [id1]) + + , testProperty "remove last in sub range (C5)" $ \(m1, m2, m3, m4, m5, idx1, idx2) -> + let msgs = makeMsgs $ m1 : m2 : m3 : m4 : m5 : [] + ids = idlist msgs + + (ids', _) = splitAt (idx2' + 1) ids + (_, matchIds) = splitAt idx1' ids' + id1 = head matchIds + id2 = last matchIds + + idxl = sort $ map (\v -> abs v `mod` 5) [idx1, idx2] + idx1' = head idxl + idx2' = last idxl + + (remaining, removed) = removeMatchesFromSubset (\m -> m^.mPostId == id2) id1 id2 msgs + in uniqueIds msgs && isJust id1 && isJust id2 ==> + counterexample ("with idlist " <> show (idlist msgs) <> + "\n idx1=" <> show idx1' <> + "\n idx2=" <> show idx2' <> + "\n extracts=" <> show (idlist removed) <> + "\n matching=" <> show matchIds <> + "\n and leaves remaining=" <> show (idlist remaining) + ) $ + (idlist remaining == (filter (/= id2) ids) && + idlist removed == [id2]) + + , testProperty "remove some in sub range (C5)" $ \(m1, m2, m3, m4, m5, idx1, idx2) -> + let msgs = makeMsgs $ m1 : m2 : m3 : m4 : m5 : [] + ids = idlist msgs + + (ids', _) = splitAt (idx2' + 1) ids + (_, matchIds) = splitAt idx1' ids' + id1 = head matchIds + id2 = last matchIds + + idxl = sort $ map (\v -> abs v `mod` 5) [idx1, idx2] + idx1' = head idxl + idx2' = last idxl + + rmvIds = map snd $ filter (odd . fst) $ zip [(0::Int)..] matchIds + + (remaining, removed) = removeMatchesFromSubset (\m -> m^.mPostId `elem` rmvIds) id1 id2 msgs + in uniqueIds msgs && isJust id1 && isJust id2 ==> + counterexample ("with idlist " <> show (idlist msgs) <> + "\n idx1=" <> show idx1' <> + "\n idx2=" <> show idx2' <> + "\n matching=" <> show matchIds <> + "\n removing=" <> show rmvIds <> + "\n extracts=" <> show (idlist removed) <> + "\n and leaves remaining=" <> show (idlist remaining) <> + "\n from " <> show (filter (not . flip elem rmvIds) ids) + ) $ + (idlist remaining == (filter (not . flip elem rmvIds) ids) && + idlist removed == rmvIds) + + , testProperty "remove from start last Nothing (C4)" $ \(m1, m2, m3, m4, m5, idx1) -> + let msgs = makeMsgs $ m1 : m2 : m3 : m4 : m5 : [] + ids = idlist msgs + + (leftIds, matchIds) = splitAt idx1' ids + id1 = head matchIds + + idx1' = abs idx1 `mod` 5 + + (remaining, removed) = removeMatchesFromSubset (const True) id1 Nothing msgs + in uniqueIds msgs && isJust id1 ==> + counterexample ("with idlist " <> show (idlist msgs) <> + "\n idx1=" <> show idx1' <> + "\n extracts=" <> show (idlist removed) <> + "\n matching=" <> show matchIds <> + "\n and leaves remaining=" <> show (idlist remaining) + ) $ + (idlist remaining == leftIds && + idlist removed == matchIds) + + , testProperty "remove from Nothing to offset (C2)" $ \(m1, m2, m3, m4, m5, idx1) -> + let msgs = makeMsgs $ m1 : m2 : m3 : m4 : m5 : [] + ids = idlist msgs + + (matchIds, leftIds) = splitAt (idx1' + 1) ids + id1 = last matchIds + + idx1' = abs idx1 `mod` 4 + + (remaining, removed) = removeMatchesFromSubset (const True) Nothing id1 msgs + in uniqueIds msgs && isJust id1 ==> + counterexample ("with idlist " <> show (idlist msgs) <> + "\n idx1=" <> show idx1' <> + "\n extracts=" <> show (idlist removed) <> + "\n matching=" <> show matchIds <> + "\n and leaves remaining=" <> show (idlist remaining) + ) $ + (idlist remaining == leftIds && + idlist removed == matchIds) + + , testProperty "remove from start not found last Nothing (C7)" $ \(m1, m2, m3, m4, m5, id1) -> + let msgs = makeMsgs $ m1 : m2 : m3 : m4 : m5 : [] + ids = idlist msgs + (remaining, removed) = removeMatchesFromSubset (const True) id1 Nothing msgs + in uniqueIds msgs && isJust id1 && (not $ id1 `elem` ids) ==> + counterexample ("with idlist " <> show ids <> + "\n extracts=" <> show (idlist removed) <> + "\n and leaves remaining=" <> show (idlist remaining) + ) $ + (idlist remaining == ids && + null removed) + + , testProperty "remove from Nothing to end not found (C3)" $ \(m1, m2, m3, m4, m5, id1) -> + let msgs = makeMsgs $ m1 : m2 : m3 : m4 : m5 : [] + ids = idlist msgs + (remaining, removed) = removeMatchesFromSubset (const True) Nothing id1 msgs + in uniqueIds msgs && isJust id1 && (not $ id1 `elem` ids) ==> + counterexample ("with idlist " <> show ids <> + "\n extracts=" <> show (idlist removed) <> + "\n and leaves remaining=" <> show (idlist remaining) + ) $ + (idlist remaining == ids && + null removed) + + , testProperty "remove from Nothing to Nothing (C1)" $ \(m1, m2, m3, m4, m5, id1) -> + let msgs = makeMsgs $ m1 : m2 : m3 : m4 : m5 : [] + ids = idlist msgs + (remaining, removed) = removeMatchesFromSubset (const True) Nothing Nothing msgs + in uniqueIds msgs && isJust id1 && (not $ id1 `elem` ids) ==> + counterexample ("with idlist " <> show ids <> + "\n extracts=" <> show (idlist removed) <> + "\n and leaves remaining=" <> show (idlist remaining) + ) $ + (idlist removed == ids && + null remaining) + + ] instanceTests :: TestTree instanceTests = testGroup "Messages Instances"