matterhorn 40600.0.0 → 40600.1.0
raw patch · 37 files changed
+1221/−693 lines, 37 filesdep +brick-skylightingdep ~brickdep ~mattermost-apidep ~mattermost-api-qc
Dependencies added: brick-skylighting
Dependency ranges changed: brick, mattermost-api, mattermost-api-qc, skylighting, tasty-quickcheck
Files
- CHANGELOG.md +16/−0
- README.md +4/−1
- matterhorn.cabal +11/−8
- src/Command.hs +38/−13
- src/Draw.hs +1/−2
- src/Draw/ChannelList.hs +1/−1
- src/Draw/JoinChannel.hs +3/−4
- src/Draw/Main.hs +30/−36
- src/Draw/Messages.hs +17/−6
- src/Draw/ShowHelp.hs +2/−2
- src/Events.hs +16/−13
- src/Events/ChannelScroll.hs +1/−1
- src/Events/ChannelSelect.hs +2/−2
- src/Events/DeleteChannelConfirm.hs +2/−3
- src/Events/JoinChannel.hs +1/−1
- src/Events/Keybindings.hs +8/−0
- src/Events/LeaveChannelConfirm.hs +1/−2
- src/Events/Main.hs +4/−4
- src/Events/MessageSelect.hs +3/−4
- src/Events/ShowHelp.hs +2/−3
- src/Events/UrlSelect.hs +1/−2
- src/Login.hs +4/−4
- src/Markdown.hs +6/−10
- src/State.hs +282/−271
- src/State/Common.hs +5/−33
- src/State/Messages.hs +112/−0
- src/State/PostListOverlay.hs +4/−3
- src/State/Setup.hs +12/−12
- src/Themes.hs +20/−69
- src/Types.hs +43/−20
- src/Types/Channels.hs +31/−102
- src/Types/DirectionalSeq.hs +55/−1
- src/Types/Messages.hs +137/−52
- src/Types/Posts.hs +1/−0
- src/Types/Users.hs +5/−1
- test/Message_QCA.hs +9/−3
- test/test_messages.hs +331/−4
CHANGELOG.md view
@@ -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 =========
README.md view
@@ -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
matterhorn.cabal view
@@ -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
src/Command.hs view
@@ -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 ])
src/Draw.hs view
@@ -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
src/Draw/ChannelList.hs view
@@ -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.
src/Draw/JoinChannel.hs view
@@ -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)
src/Draw/Main.hs view
@@ -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))
src/Draw/Messages.hs view
@@ -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
src/Draw/ShowHelp.hs view
@@ -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 "
src/Events.hs view
@@ -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
src/Events/ChannelScroll.hs view
@@ -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"
src/Events/ChannelSelect.hs view
@@ -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 ]
src/Events/DeleteChannelConfirm.hs view
@@ -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
src/Events/JoinChannel.hs view
@@ -35,6 +35,6 @@ Nothing -> return () Just (_, chan) -> joinChannel chan onEventJoinChannel (Vty.EvKey Vty.KEsc []) = do- csMode .= Main+ setMode Main onEventJoinChannel _ = do return ()
src/Events/Keybindings.hs view
@@ -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 =
src/Events/LeaveChannelConfirm.hs view
@@ -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 ()
src/Events/Main.hs view
@@ -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.
src/Events/MessageSelect.hs view
@@ -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
src/Events/ShowHelp.hs view
@@ -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"
src/Events/UrlSelect.hs view
@@ -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
src/Login.hs view
@@ -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 =
src/Markdown.hs view
@@ -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 =
src/State.hs view
@@ -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 ()
src/State/Common.hs view
@@ -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) ]
+ src/State/Messages.hs view
@@ -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 ()
src/State/PostListOverlay.hs view
@@ -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 ()
src/State/Setup.hs view
@@ -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
src/Themes.hs view
@@ -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"
src/Types.hs view
@@ -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
src/Types/Channels.hs view
@@ -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
src/Types/DirectionalSeq.hs view
@@ -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
src/Types/Messages.hs view
@@ -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
src/Types/Posts.hs view
@@ -86,6 +86,7 @@ | Error | DateTransition | NewMessagesTransition+ | UnknownGap -- ^ marks region where server may have messages unknown locally deriving (Eq, Show) -- ** 'ClientMessage' Lenses
src/Types/Users.hs view
@@ -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]
test/Message_QCA.hs view
@@ -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
test/test_messages.hs view
@@ -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"