diff --git a/README.md b/README.md --- a/README.md +++ b/README.md @@ -135,6 +135,7 @@ * Syntax highlighting of fenced code blocks in messages (works best in 256-color terminals) * Flagging and unflagging of posts, which are then viewable with `M-8` + or `/flags` # Spell Checking Support @@ -193,6 +194,9 @@ discuss any usability / UI, performance, or compatibility issues. - Please make changes consistent with the conventions already used in the codebase. + - We follow a few development practices to support our project and it + helps when contributors are aware of these. Please see `PRACTICES.md` + for more information. # Frequently Asked Questions diff --git a/matterhorn.cabal b/matterhorn.cabal --- a/matterhorn.cabal +++ b/matterhorn.cabal @@ -1,5 +1,5 @@ name: matterhorn -version: 31000.0.0 +version: 40000.0.0 synopsis: Terminal client for the Mattermost chat system description: This is a terminal client for the Mattermost chat system. Please see the README for a list of @@ -11,7 +11,7 @@ copyright: ©2016-2017 AUTHORS.txt category: Chat build-type: Simple -cabal-version: >= 1.12 +cabal-version: >= 1.18 tested-with: GHC == 7.10.3, GHC == 8.0.1 extra-doc-files: README.md @@ -32,6 +32,7 @@ State.Editing State.PostListOverlay State.Setup + State.Setup.Threads Zipper Themes Draw @@ -74,7 +75,7 @@ ScopedTypeVariables ghc-options: -Wall -threaded build-depends: base >=4.8 && <5 - , mattermost-api == 31000.0.0 + , mattermost-api == 40000.0.0 , base-compat >= 0.9 && < 0.10 , unordered-containers >= 0.2 && < 0.3 , containers >= 0.5.7 && < 0.6 @@ -89,7 +90,7 @@ , vty >= 5.15.1 && < 5.16 , transformers >= 0.4 && < 0.6 , text-zipper >= 0.10 && < 0.11 - , time >= 1.6 && < 1.8 + , time >= 1.6 && < 1.9 , xdg-basedir >= 0.2 && < 0.3 , filepath >= 1.4 && < 1.5 , directory >= 1.3 && < 1.4 @@ -131,8 +132,8 @@ , filepath >= 1.4 && < 1.5 , hashable >= 1.2 && < 1.3 , Hclip >= 3.0 && < 3.1 - , mattermost-api == 31000.0.0 - , mattermost-api-qc == 31000.0.0 + , mattermost-api == 40000.0.0 + , mattermost-api-qc == 40000.0.0 , microlens-platform >= 0.3 && < 0.4 , mtl >= 2.2 && < 2.3 , process >= 1.4 && < 1.7 @@ -145,10 +146,10 @@ , tasty-quickcheck >= 0.8 && < 0.9 , text >= 1.2 && < 1.3 , text-zipper >= 0.10 && < 0.11 - , time >= 1.6 && < 1.8 + , time >= 1.6 && < 1.9 , transformers >= 0.4 && < 0.6 , Unique >= 0.4 && < 0.5 , unordered-containers >= 0.2 && < 0.3 - , vector < 0.12 + , vector <= 0.12.0.1 , vty >= 5.15.1 && < 5.16 , xdg-basedir >= 0.2 && < 0.3 diff --git a/src/Config.hs b/src/Config.hs --- a/src/Config.hs +++ b/src/Config.hs @@ -40,6 +40,8 @@ configURLOpenCommand <- fieldMbOf "urlOpenCommand" stringField configSmartBacktick <- fieldFlagDef "smartbacktick" (configSmartBacktick defaultConfig) + configShowBackground <- fieldDefOf "showBackgroundActivity" backgroundField + (configShowBackground defaultConfig) configShowMessagePreview <- fieldFlagDef "showMessagePreview" (configShowMessagePreview defaultConfig) configEnableAspell <- fieldFlagDef "enableAspell" @@ -49,8 +51,19 @@ configPass <- (Just . PasswordCommand <$> field "passcmd") <|> (Just . PasswordString <$> field "pass") <|> pure Nothing + configUnsafeUseHTTP <- + fieldFlagDef "unsafeUseUnauthenticatedConnection" False return Config { .. } +backgroundField :: T.Text -> Either String BackgroundInfo +backgroundField t = + case t of + "Disabled" -> Right Disabled + "Active" -> Right Active + "ActiveCount" -> Right ActiveCount + _ -> Left ("Invalid value " <> show t + <> "; must be one of: Disabled, Active, ActiveCount") + stringField :: T.Text -> Either String T.Text stringField t = case isQuoted t of @@ -84,9 +97,11 @@ , configSmartBacktick = True , configURLOpenCommand = Nothing , configActivityBell = False + , configShowBackground = Disabled , configShowMessagePreview = False , configEnableAspell = False , configAspellDictionary = Nothing + , configUnsafeUseHTTP = False } findConfig :: Maybe FilePath -> IO (Either String Config) diff --git a/src/Connection.hs b/src/Connection.hs --- a/src/Connection.hs +++ b/src/Connection.hs @@ -17,7 +17,7 @@ connectWebsockets :: ChatState -> IO () connectWebsockets st = do let shunt e = writeBChan (st^.csResources.crEventQueue) (WSEvent e) - let runWS = mmWithWebSocket (st^.csSession) shunt $ \ _ -> do + let runWS = mmWithWebSocket (st^.csResources.crSession) shunt $ \ _ -> do writeBChan (st^.csResources.crEventQueue) WebsocketConnect waitAndQuit st void $ forkIO $ runWS `catch` handleTimeout 1 st diff --git a/src/Draw/ChannelList.hs b/src/Draw/ChannelList.hs --- a/src/Draw/ChannelList.hs +++ b/src/Draw/ChannelList.hs @@ -1,4 +1,5 @@ {-# LANGUAGE MultiWayIf #-} +{-# LANGUAGE RankNTypes #-} -- | This module provides the Drawing functionality for the -- ChannelList sidebar. The sidebar is divided vertically into groups @@ -20,6 +21,7 @@ import Brick import Brick.Widgets.Border import qualified Data.HashMap.Strict as HM +import Data.List (sortBy, partition) import Data.Monoid ((<>)) import qualified Data.Text as T import Draw.Util @@ -160,7 +162,7 @@ unread = hasUnread st chan recent = Just chan == st^.csRecentChannel current = isCurrentChannel st chan - sigil = case st ^. csLastChannelInput . at chan of + sigil = case st ^. csEditState.cedLastChannelInput.at chan of Nothing -> T.singleton normalChannelSigil Just ("", _) -> T.singleton normalChannelSigil _ -> "»" @@ -174,7 +176,7 @@ [ ChannelListEntry sigil uname unread mentions recent current (Just $ u^.uiStatus) | u <- sortedUserList st , let sigil = - case do { cId <- m_chanId; st^.csLastChannelInput.at cId } of + case do { cId <- m_chanId; st^.csEditState.cedLastChannelInput.at cId } of Nothing -> T.singleton $ userSigilFromInfo u Just ("", _) -> T.singleton $ userSigilFromInfo u _ -> "»" -- shows that user has a message in-progress @@ -187,3 +189,24 @@ Just cId -> maybe 0 id (st^?csChannel(cId).ccInfo.cdMentionCount) Nothing -> 0 ] + +sortedUserList :: ChatState -> [UserInfo] +sortedUserList st = sortBy cmp yes <> sortBy cmp no + where + cmp = compareUserInfo uiName + dmHasUnread u = + case st^.csNames.cnToChanId.at(u^.uiName) of + Nothing -> False + Just cId + | (st^.csCurrentChannelId) == cId -> False + | otherwise -> hasUnread st cId + (yes, no) = partition dmHasUnread (userList st) + +compareUserInfo :: (Ord a) => Lens' UserInfo a -> UserInfo -> UserInfo -> Ordering +compareUserInfo field u1 u2 + | u1^.uiStatus == Offline && u2^.uiStatus /= Offline = + GT + | u1^.uiStatus /= Offline && u2^.uiStatus == Offline = + LT + | otherwise = + (u1^.field) `compare` (u2^.field) diff --git a/src/Draw/Main.hs b/src/Draw/Main.hs --- a/src/Draw/Main.hs +++ b/src/Draw/Main.hs @@ -44,6 +44,7 @@ import Types import Types.Channels ( NewMessageIndicator(..) , ChannelState(..) + , ClientChannel , ccInfo, ccContents , cdCurrentState , cdName, cdType, cdHeader, cdMessages @@ -236,13 +237,13 @@ Replying _ _ -> "reply> " Editing _ -> "edit> " NewPost -> "> " - inputBox = renderEditor (drawEditorContents uSet cSet st) True (st^.csCmdLine) - curContents = getEditContents $ st^.csCmdLine + inputBox = renderEditor (drawEditorContents uSet cSet st) True (st^.csEditState.cedEditor) + curContents = getEditContents $ st^.csEditState.cedEditor multilineContent = length curContents > 1 multilineHints = hBox [ borderElem bsHorizontal , str $ "[" <> (show $ (+1) $ fst $ cursorPosition $ - st^.csCmdLine.editContentsL) <> + st^.csEditState.cedEditor.editContentsL) <> "/" <> (show $ length curContents) <> "]" , hBorderWithLabel $ withDefAttr clientEmphAttr $ str "In multi-line mode. Press M-e to finish." @@ -274,6 +275,34 @@ True -> vLimit 5 inputBox <=> multilineHints in replyDisplay <=> commandBox +renderChannelHeader :: UserSet -> ChannelSet -> ChatState -> ClientChannel -> Widget Name +renderChannelHeader uSet cSet st chan = + let chnType = chan^.ccInfo.cdType + chnName = chan^.ccInfo.cdName + topicStr = chan^.ccInfo.cdHeader + userHeader u = let s = T.intercalate " " $ filter (not . T.null) parts + parts = [ u^.uiName + , " is" + , u^.uiFirstName + , nick + , u^.uiLastName + , "(" <> u^.uiEmail <> ")" + ] + quote n = "\"" <> n <> "\"" + nick = maybe "" quote $ u^.uiNickName + in s + foundUser = findUserByDMChannelName (st^.csUsers) chnName (st^.csMe^.userIdL) + maybeTopic = if T.null topicStr + then "" + else " - " <> topicStr + channelNameString = case chnType of + Direct -> + case foundUser of + Nothing -> mkChannelName (chan^.ccInfo) + Just u -> userHeader u + _ -> mkChannelName (chan^.ccInfo) + in renderText' uSet cSet (channelNameString <> maybeTopic) + renderCurrentChannelDisplay :: UserSet -> ChannelSet -> ChatState -> Widget Name renderCurrentChannelDisplay uSet cSet st = (header <+> conn) <=> messages where @@ -282,28 +311,7 @@ Disconnected -> withDefAttr errorMessageAttr (str "[NOT CONNECTED]") header = withDefAttr channelHeaderAttr $ padRight Max $ - case T.null topicStr of - True -> case chnType of - Direct -> - case findUserByDMChannelName (st^.csUsers) - chnName - (st^.csMe^.userIdL) of - Nothing -> txt $ mkChannelName (chan^.ccInfo) - Just u -> userHeader u - _ -> txt $ mkChannelName (chan^.ccInfo) - False -> renderText $ - mkChannelName (chan^.ccInfo) <> " - " <> topicStr - userHeader u = let p1 = (colorUsername $ mkDMChannelName u) - p2 = txt $ T.intercalate " " $ filter (not . T.null) parts - parts = [ " is" - , u^.uiFirstName - , nick - , u^.uiLastName - , "<" <> u^.uiEmail <> ">" - ] - quote n = "\"" <> n <> "\"" - nick = maybe "" quote $ u^.uiNickName - in p1 <+> p2 + renderChannelHeader uSet cSet st chan messages = padTop Max $ padRight (Pad 1) body body = chatText @@ -380,11 +388,7 @@ cId = st^.csCurrentChannelId chan = st^.csCurrentChannel - chnName = chan^.ccInfo.cdName - chnType = chan^.ccInfo.cdType - topicStr = chan^.ccInfo.cdHeader - -- | When displaying channel contents, it may be convenient to display -- information about the current state of the channel. stateMessage :: ChannelState -> Maybe T.Text @@ -520,7 +524,7 @@ -- end of whatever line the user is editing, that is very unlikely -- to be a problem. curContents = getText $ (gotoEOL >>> insertChar cursorSentinel) $ - st^.csCmdLine.editContentsL + st^.csEditState.cedEditor.editContentsL curStr = T.intercalate "\n" curContents previewMsg = previewFromInput uname curStr thePreview = let noPreview = str "(No preview)" @@ -569,10 +573,18 @@ bottomBorder = case st^.csMode of MessageSelect -> messageSelectBottomBar st - _ -> case st^.csCurrentCompletion of + _ -> case st^.csEditState.cedCurrentCompletion of Just _ | length (st^.csEditState.cedCompletionAlternatives) > 1 -> completionAlternatives st _ -> maybeSubdue $ hBox - [hLimit channelListWidth hBorder, borderElem bsIntersectB, hBorder] + [ hLimit channelListWidth hBorder + , borderElem bsIntersectB + , hBorder + , showBusy] + + showBusy = case st^.csWorkerIsBusy of + Just (Just n) -> txt (T.pack $ "*" <> show n) + Just Nothing -> txt "*" + Nothing -> emptyWidget maybeSubdue = if st^.csMode == ChannelSelect then forceAttr "" diff --git a/src/Draw/Messages.hs b/src/Draw/Messages.hs --- a/src/Draw/Messages.hs +++ b/src/Draw/Messages.hs @@ -57,7 +57,7 @@ C NewMessagesTransition -> withDefAttr newMessageTransitionAttr (hBorderWithLabel m) C Error -> withDefAttr errorMessageAttr m _ -> withDefAttr clientMessageAttr m - fullMsg = hBox $ msgTxt : catMaybes [msgAtch, msgReac] + fullMsg = vBox $ msgTxt : catMaybes [msgAtch, msgReac] maybeRenderTime w = hBox [renderTimeFunc (msg^.mDate), txt " ", w] maybeRenderTimeWith f = case msg^.mType of C DateTransition -> id diff --git a/src/Draw/Util.hs b/src/Draw/Util.hs --- a/src/Draw/Util.hs +++ b/src/Draw/Util.hs @@ -23,10 +23,12 @@ defaultDateFormat = "%Y-%m-%d" getTimeFormat :: ChatState -> T.Text -getTimeFormat st = maybe defaultTimeFormat id (st^.timeFormat) +getTimeFormat st = + maybe defaultTimeFormat id (st^.csResources.crConfiguration.to configTimeFormat) getDateFormat :: ChatState -> T.Text -getDateFormat st = maybe defaultDateFormat id (st^.dateFormat) +getDateFormat st = + maybe defaultDateFormat id (st^.csResources.crConfiguration.to configDateFormat) renderTime :: ChatState -> UTCTime -> Widget Name renderTime st = renderUTCTime (getTimeFormat st) (st^.timeZone) diff --git a/src/Events.hs b/src/Events.hs --- a/src/Events.hs +++ b/src/Events.hs @@ -21,7 +21,7 @@ import State import State.Common import Types -import Types.Channels (ccInfo, cdHeader, cdMentionCount) +import Types.Channels (ccInfo, cdMentionCount) import Events.ShowHelp import Events.Main @@ -52,6 +52,9 @@ onAppEvent WebsocketConnect = do csConnectionStatus .= Connected refreshChannels +onAppEvent BGIdle = csWorkerIsBusy .= Nothing +onAppEvent (BGBusy n) = csWorkerIsBusy .= Just n + onAppEvent (WSEvent we) = handleWSEvent we onAppEvent (RespEvent f) = f @@ -96,10 +99,6 @@ -- If the message is a header change, also update the channel -- metadata. myUserId <- use (csMe.userIdL) - case postPropsNewHeader (p^.postPropsL) of - Just newHeader | postType p == PostTypeHeaderChange -> - csChannel(postChannelId p).ccInfo.cdHeader .= newHeader - _ -> return () case wepMentions (weData we) of Just lst | myUserId `Set.member` lst -> @@ -209,3 +208,13 @@ WMWebRTC -> return () WMAuthenticationChallenge -> return () + + WMChannelViewed -> + case webChannelId $ weBroadcast we of + Just cId -> refreshChannel False cId + Nothing -> return () + + WMChannelUpdated -> + case webChannelId $ weBroadcast we of + Just cId -> refreshChannel False cId + Nothing -> return () diff --git a/src/Events/Main.hs b/src/Events/Main.hs --- a/src/Events/Main.hs +++ b/src/Events/Main.hs @@ -75,7 +75,7 @@ -- navigate the history. isMultiline <- use (csEditState.cedMultiline) case isMultiline of - True -> mhHandleEventLensed csCmdLine handleEditorEvent + True -> mhHandleEventLensed (csEditState.cedEditor) handleEditorEvent (Vty.EvKey Vty.KUp []) False -> channelHistoryBackward @@ -85,7 +85,7 @@ -- we navigate the history. isMultiline <- use (csEditState.cedMultiline) case isMultiline of - True -> mhHandleEventLensed csCmdLine handleEditorEvent + True -> mhHandleEventLensed (csEditState.cedEditor) handleEditorEvent (Vty.EvKey Vty.KDown []) False -> channelHistoryForward @@ -121,10 +121,10 @@ -- Enter in multiline mode does the usual thing; we -- only send on Enter when we're outside of multiline -- mode. - True -> mhHandleEventLensed csCmdLine handleEditorEvent + True -> mhHandleEventLensed (csEditState.cedEditor) handleEditorEvent (Vty.EvKey Vty.KEnter []) False -> do - csCurrentCompletion .= Nothing + csEditState.cedCurrentCompletion .= Nothing handleInputSubmission , KB "Select and open a URL posted to the current channel" @@ -154,7 +154,7 @@ handleInputSubmission :: MH () handleInputSubmission = do - cmdLine <- use csCmdLine + cmdLine <- use (csEditState.cedEditor) cId <- use csCurrentChannelId -- send the relevant message @@ -165,9 +165,9 @@ -- We clean up before dispatching the command or sending the message -- since otherwise the command could change the state and then doing -- cleanup afterwards could clean up the wrong things. - csCmdLine %= applyEdit Z.clearZipper - csInputHistory %= addHistoryEntry allLines cId - csInputHistoryPosition.at cId .= Nothing + csEditState.cedEditor %= applyEdit Z.clearZipper + csEditState.cedInputHistory %= addHistoryEntry allLines cId + csEditState.cedInputHistoryPosition.at cId .= Nothing csEditState.cedEditMode .= NewPost case T.uncons line of @@ -193,19 +193,19 @@ map (T.singleton normalChannelSigil <>) completableChannels ++ map ("/" <>) (commandName <$> commandList)) - line = Z.currentLine $ st^.csCmdLine.editContentsL - curComp = st^.csCurrentCompletion + line = Z.currentLine $ st^.csEditState.cedEditor.editContentsL + curComp = st^.csEditState.cedCurrentCompletion (nextComp, alts) = case curComp of Nothing -> let cw = currentWord line in (Just cw, filter (cw `T.isPrefixOf`) $ Set.toList completions) Just cw -> (Just cw, filter (cw `T.isPrefixOf`) $ Set.toList completions) mb_word = wordComplete dir priorities completions line curComp - csCurrentCompletion .= nextComp + csEditState.cedCurrentCompletion .= nextComp csEditState.cedCompletionAlternatives .= alts let (edit, curAlternative) = case mb_word of Nothing -> (id, "") Just w -> (Z.insertMany w . Z.deletePrevWord, w) - csCmdLine %= (applyEdit edit) + csEditState.cedEditor %= (applyEdit edit) csEditState.cedCurrentAlternative .= curAlternative diff --git a/src/Main.hs b/src/Main.hs --- a/src/Main.hs +++ b/src/Main.hs @@ -41,7 +41,29 @@ requestChan <- STM.atomically STM.newTChan void $ forkIO $ forever $ do + startWork <- + case configShowBackground config of + Disabled -> return $ return () + Active -> do chk <- STM.atomically $ STM.tryPeekTChan requestChan + case chk of + Nothing -> do writeBChan eventChan BGIdle + return $ writeBChan eventChan $ BGBusy Nothing + _ -> return $ return () + ActiveCount -> do + chk <- STM.atomically $ do + chanCopy <- STM.cloneTChan requestChan + let cntMsgs = do m <- STM.tryReadTChan chanCopy + case m of + Nothing -> return 0 + Just _ -> (1 +) <$> cntMsgs + cntMsgs + case chk of + 0 -> do writeBChan eventChan BGIdle + return (writeBChan eventChan $ BGBusy (Just 1)) + _ -> do writeBChan eventChan $ BGBusy (Just chk) + return $ return () req <- STM.atomically $ STM.readTChan requestChan + startWork res <- try req case res of Left e -> writeBChan eventChan (AsyncErrEvent e) @@ -62,12 +84,12 @@ case finalSt^.csEditState.cedSpellChecker of Nothing -> return () - Just s -> stopAspell s + Just (s, _) -> stopAspell s case logFile of Nothing -> return () Just h -> hClose h - writeHistory (finalSt^.csInputHistory) + writeHistory (finalSt^.csEditState.cedInputHistory) app :: App ChatState MHEvent Name app = App diff --git a/src/Markdown.hs b/src/Markdown.hs --- a/src/Markdown.hs +++ b/src/Markdown.hs @@ -7,6 +7,7 @@ , ChannelSet , renderMessage , renderText + , renderText' , blockGetURLs , cursorSentinel , addEllipsis @@ -142,7 +143,10 @@ -- Render text to markdown without username highlighting renderText :: Text -> Widget a -renderText txt = renderMarkdown Set.empty Set.empty bs +renderText txt = renderText' Set.empty Set.empty txt + +renderText' :: UserSet -> ChannelSet -> Text -> Widget a +renderText' uSet cSet txt = renderMarkdown uSet cSet bs where C.Doc _ bs = C.markdown C.def txt vBox :: F.Foldable f => f (Widget a) -> Widget a @@ -283,8 +287,8 @@ go Emph is <> go n xs C.Strong is :< xs -> go Strong is <> go n xs - C.Image _ _ _ :< xs -> - Fragment (TStr "[img]") Link <| go n xs + C.Image altIs _ _ :< xs -> + Fragment (TStr ("[image" <> altInlinesString altIs <> "]")) Link <| go n xs C.Entity t :< xs -> Fragment (TStr t) Link <| go n xs EmptyL -> S.empty @@ -414,12 +418,13 @@ go (C.Strong is) = F.fold (fmap go is) go (C.Code t) = t go (C.Link is _ _) = F.fold (fmap go is) - go (C.Image _ _ _) = "[img]" + go (C.Image is _ _) = "[image" <> altInlinesString is <> "]" go (C.Entity t) = t go (C.RawHtml t) = t - - +altInlinesString :: S.Seq C.Inline -> T.Text +altInlinesString is | S.null is = "" + | otherwise = ":" <> inlinesToText is blockGetURLs :: C.Block -> S.Seq (T.Text, T.Text) blockGetURLs (C.Para is) = mconcat $ inlineGetURLs <$> F.toList is @@ -433,7 +438,7 @@ inlineGetURLs (C.Strong is) = mconcat $ inlineGetURLs <$> F.toList is inlineGetURLs (C.Link is url "") = (url, inlinesToText is) S.<| (mconcat $ inlineGetURLs <$> F.toList is) inlineGetURLs (C.Link is _ url) = (url, inlinesToText is) S.<| (mconcat $ inlineGetURLs <$> F.toList is) -inlineGetURLs (C.Image is _ _) = mconcat $ inlineGetURLs <$> F.toList is +inlineGetURLs (C.Image is url _) = S.singleton (url, inlinesToText is) inlineGetURLs _ = mempty replyArrow :: Widget a diff --git a/src/State.hs b/src/State.hs --- a/src/State.hs +++ b/src/State.hs @@ -69,8 +69,8 @@ -- | Refresh information about a specific channel. The channel -- metadata is refreshed, and if this is a loaded channel, the -- scrollback is updated as well. -refreshChannel :: ChannelId -> MH () -refreshChannel cId = do +refreshChannel :: Bool -> ChannelId -> MH () +refreshChannel refreshMessages cId = do curId <- use csCurrentChannelId let priority = if curId == cId then Preempt else Normal asPending doAsyncChannelMM priority (Just cId) mmGetChannel postRefreshChannel @@ -78,7 +78,7 @@ updateChannelInfo cId' cwd -- If this is an active channel, also update the Messages to -- retrieve any that might have been missed. - updateMessages cId' + when refreshMessages $ updateMessages cId' -- | Refresh information about all channels. This is usually -- triggered when a reconnect event for the WebSocket to the server @@ -86,7 +86,7 @@ refreshChannels :: MH () refreshChannels = do cIds <- use (csChannels.to (filteredChannelIds (const True))) - sequence_ $ refreshChannel <$> cIds + sequence_ $ refreshChannel True <$> cIds -- | Update the indicted Channel entry with the new data retrieved -- from the Mattermost server. @@ -129,8 +129,8 @@ withChannel cId $ \chan -> do let last_pId = getLatestPostId (chan^.ccContents.cdMessages) newCutoff = chan^.ccInfo.cdNewMessageIndicator - asPending doAsyncChannelMM prio (Just cId) - (let fc = case last_pId of + fetchMessages s t c = do + let fc = case last_pId of Nothing -> F1 -- or F4 Just pId -> case findMessage pId (chan^.ccContents.cdMessages) of @@ -159,18 +159,18 @@ if m^.mDate >= ct then F3b pId else F3a - op = case fc of - F1 -> ___2 mmGetPosts - F2 pId -> ___3 mmGetPostsAfter pId - F3a -> ___2 mmGetPosts - F3b pId -> ___3 mmGetPostsBefore pId - F4 -> ___2 mmGetPosts - in op 0 numScrollbackPosts - ) - addObtainedMessages + op = case fc of + F1 -> mmGetPosts s t c + F2 pId -> mmGetPostsAfter s t c pId + F3a -> mmGetPosts s t c + F3b pId -> mmGetPostsBefore s t c pId + F4 -> mmGetPosts s t c + op 0 numScrollbackPosts -data FetchCase = F1 | F2 PostId | F3a | F3b PostId | F4 deriving (Eq,Show) + asPending doAsyncChannelMM prio (Just cId) fetchMessages + addObtainedMessages +data FetchCase = F1 | F2 PostId | F3a | F3b PostId | F4 deriving (Eq,Show) -- * Message selection mode @@ -221,9 +221,6 @@ csMessageSelect .= MessageSelectState (nextPostId <|> selected) _ -> return () -isMine :: ChatState -> Message -> Bool -isMine st msg = (Just $ st^.csMe.userUsernameL) == msg^.mUserName - messageSelectDownBy :: Int -> MH () messageSelectDownBy amt | amt <= 0 = return () @@ -249,7 +246,7 @@ case msg^.mOriginalPost of Just p -> doAsyncChannelMM Preempt Nothing - (___1 mmDeletePost (postId p)) + (\s t c -> mmDeletePost s t c (postId p)) (\_ _ -> do csEditState.cedEditMode .= NewPost csMode .= Main) Nothing -> return () @@ -315,7 +312,7 @@ -- | Tell the server that we have flagged or unflagged a message. flagMessage :: PostId -> Bool -> MH () flagMessage pId f = do - session <- use csSession + session <- use (csResources.crSession) myId <- use (csMe.userIdL) doAsyncWith Normal $ do let doFlag = if f then mmFlagPost else mmUnflagPost @@ -342,7 +339,7 @@ let Just p = msg^.mOriginalPost csMode .= Main csEditState.cedEditMode .= Editing p - csCmdLine %= applyEdit (clearZipper >> (insertMany $ postMessage p)) + csEditState.cedEditor %= applyEdit (clearZipper >> (insertMany $ postMessage p)) _ -> return () replyToLatestMessage :: MH () @@ -371,7 +368,7 @@ NewPost -> return () _ -> do csEditState.cedEditMode .= NewPost - csCmdLine %= applyEdit clearZipper + csEditState.cedEditor %= applyEdit clearZipper copyVerbatimToClipboard :: MH () copyVerbatimToClipboard = do @@ -388,7 +385,7 @@ startJoinChannel :: MH () startJoinChannel = do - session <- use csSession + session <- use (csResources.crSession) myTeamId <- use (csMyTeam.teamIdL) doAsyncWith Preempt $ do -- We don't get to just request all channels, so we request channels in @@ -419,7 +416,7 @@ handleChannelInvite cId = do st <- use id doAsyncWith Normal $ do - tryMM (mmGetChannel (st^.csSession) (st^.csMyTeam.teamIdL) cId) + tryMM (mmGetChannel (st^.csResources.crSession) (st^.csMyTeam.teamIdL) cId) (\(ChannelWithData chan _) -> do return $ do handleNewChannel (preferredChannelName chan) False chan @@ -439,10 +436,10 @@ when (canLeaveChannel (chan^.ccInfo)) $ doAsyncChannelMM Preempt (Just cId) mmLeaveChannel - removeChannelFromState + (\c () -> removeChannelFromState c) -removeChannelFromState :: ChannelId -> a -> MH () -removeChannelFromState cId _ = do +removeChannelFromState :: ChannelId -> MH () +removeChannelFromState cId = do withChannel cId $ \ chan -> do let cName = chan^.ccInfo.cdName chType = chan^.ccInfo.cdType @@ -467,7 +464,7 @@ fetchCurrentChannelMembers :: MH () fetchCurrentChannelMembers = doAsyncChannelMM Preempt Nothing - (___2 mmGetChannelMembers 0 10000) + (\s t c -> mmGetChannelMembers s t c 0 10000) (\_ chanUserMap -> do -- Construct a message listing them all and post it to the -- channel: @@ -481,8 +478,8 @@ -- | Called on async completion when the currently viewed channel has -- been updated (i.e., just switched to this channel) to update local -- state. -setLastViewedFor :: Maybe ChannelId -> ChannelId -> () -> MH () -setLastViewedFor prevId cId _ = do +setLastViewedFor :: Maybe ChannelId -> ChannelId -> MH () +setLastViewedFor prevId cId = do chan <- use (csChannels.to (findChannelById cId)) -- Update new channel's viewed time, creating the channel if needed case chan of @@ -534,8 +531,8 @@ -- Only do this if we're connected to avoid triggering noisy exceptions. pId <- use csRecentChannel doAsyncChannelMM Preempt (Just cId) - (___1 mmViewChannel pId) - (setLastViewedFor pId) + (\s t c -> mmViewChannel s t c pId) + (\c () -> setLastViewedFor pId c) Disconnected -> -- Cannot update server; make no local updates to avoid -- getting out-of-sync with the server. Assumes that this @@ -548,36 +545,36 @@ resetHistoryPosition :: MH () resetHistoryPosition = do cId <- use csCurrentChannelId - csInputHistoryPosition.at cId .= Just Nothing + csEditState.cedInputHistoryPosition.at cId .= Just Nothing updateStatus :: UserId -> T.Text -> MH () updateStatus uId t = csUsers %= modifyUserById uId (uiStatus .~ statusFromText t) clearEditor :: MH () -clearEditor = csCmdLine %= applyEdit clearZipper +clearEditor = csEditState.cedEditor %= applyEdit clearZipper loadLastEdit :: MH () loadLastEdit = do cId <- use csCurrentChannelId - lastInput <- use (csLastChannelInput.at cId) + lastInput <- use (csEditState.cedLastChannelInput.at cId) case lastInput of Nothing -> return () Just (lastEdit, lastEditMode) -> do - csCmdLine %= (applyEdit $ insertMany (lastEdit) . clearZipper) + csEditState.cedEditor %= (applyEdit $ insertMany (lastEdit) . clearZipper) csEditState.cedEditMode .= lastEditMode saveCurrentEdit :: MH () saveCurrentEdit = do cId <- use csCurrentChannelId - cmdLine <- use csCmdLine + cmdLine <- use (csEditState.cedEditor) mode <- use (csEditState.cedEditMode) - csLastChannelInput.at cId .= + csEditState.cedLastChannelInput.at cId .= Just (T.intercalate "\n" $ getEditContents $ cmdLine, mode) resetCurrentEdit :: MH () resetCurrentEdit = do cId <- use csCurrentChannelId - csLastChannelInput.at cId .= Nothing + csEditState.cedLastChannelInput.at cId .= Nothing updateChannelListScroll :: MH () updateChannelListScroll = do @@ -693,7 +690,7 @@ withChannel cId $ \chan -> let offset = length $ chan^.ccContents.cdMessages in asPending doAsyncChannelMM Preempt (Just cId) - (___2 mmGetPosts offset pageAmount) + (\s t c -> mmGetPosts s t c offset pageAmount) (\c p -> do addObtainedMessages c p mh $ invalidateCacheEntry (ChannelMessages cId)) @@ -724,7 +721,7 @@ st <- use id case channelByName st name of Just cId -> setFocus cId - Nothing -> attemptCreateDMChannel name + Nothing -> attemptCreateDMChannel name setFocus :: ChannelId -> MH () setFocus cId = setFocusWith (Z.findRight (== cId)) @@ -748,23 +745,26 @@ attemptCreateDMChannel name = do users <- use (csNames.cnUsers) nameToChanId <- use (csNames.cnToChanId) - if name `elem` users && not (name `HM.member` nameToChanId) - then do - -- We have a user of that name but no channel. Time to make one! - tId <- use (csMyTeam.teamIdL) - Just uId <- use (csNames.cnToUserId.at(name)) - session <- use csSession - doAsyncWith Normal $ do - -- create a new channel - nc <- mmCreateDirect session tId uId - return $ handleNewChannel name True nc - else - postErrorMessage ("No channel or user named " <> name) + myName <- use (csMe.userUsernameL) + if name == myName + then postErrorMessage ("Cannot create a DM channel with yourself") + else if name `elem` users && not (name `HM.member` nameToChanId) + then do + -- We have a user of that name but no channel. Time to make one! + tId <- use (csMyTeam.teamIdL) + Just uId <- use (csNames.cnToUserId.at(name)) + session <- use (csResources.crSession) + doAsyncWith Normal $ do + -- create a new channel + nc <- mmCreateDirect session tId uId + return $ handleNewChannel name True nc + else + postErrorMessage ("No channel or user named " <> name) createOrdinaryChannel :: T.Text -> MH () createOrdinaryChannel name = do tId <- use (csMyTeam.teamIdL) - session <- use csSession + session <- use (csResources.crSession) doAsyncWith Preempt $ do -- create a new chat channel let slug = T.map (\ c -> if isAlphaNum c then c else '-') (T.toLower name) @@ -810,6 +810,8 @@ chan . ccContents . cdMessages . traversed . filtered isEditedMessage .= msg chan %= adjustUpdated new csPostMap.ix(postId new) .= msg + asyncFetchReactionsForPost (postChannelId new) new + asyncFetchAttachments new cId <- use csCurrentChannelId when (postChannelId new == cId) updateViewed @@ -919,7 +921,7 @@ case getMessageForPostId st parentId of Nothing -> do doAsyncChannelMM Preempt (Just cId) - (___1 mmGetPost parentId) + (\s t c -> mmGetPost s t c parentId) (\_ p -> let postMap = HM.fromList [ ( pId , clientPostToMessage st @@ -966,7 +968,7 @@ execMMCommand :: T.Text -> T.Text -> MH () execMMCommand name rest = do cId <- use csCurrentChannelId - session <- use csSession + session <- use (csResources.crSession) myTeamId <- use (csMyTeam.teamIdL) let mc = MinCommand { minComChannelId = cId @@ -1009,35 +1011,36 @@ , c <- maybeToList (HM.lookup i (chanNames ^. cnToChanId)) ] setChannelTopic :: T.Text -> MH () -setChannelTopic msg = doAsyncChannelMM Normal Nothing - (___1 mmSetChannelHeader msg) - (\cId _ -> csChannel(cId).ccInfo.cdHeader .= msg) +setChannelTopic msg = + doAsyncChannelMM Preempt Nothing + (\s t c -> mmSetChannelHeader s t c msg) + (\_ _ -> return ()) channelHistoryForward :: MH () channelHistoryForward = do cId <- use csCurrentChannelId - inputHistoryPos <- use (csInputHistoryPosition.at cId) - inputHistory <- use csInputHistory + inputHistoryPos <- use (csEditState.cedInputHistoryPosition.at cId) + inputHistory <- use (csEditState.cedInputHistory) case inputHistoryPos of Just (Just i) | i == 0 -> do -- Transition out of history navigation - csInputHistoryPosition.at cId .= Just Nothing + csEditState.cedInputHistoryPosition.at cId .= Just Nothing loadLastEdit | otherwise -> do let Just entry = getHistoryEntry cId newI inputHistory newI = i - 1 eLines = T.lines entry mv = if length eLines == 1 then gotoEOL else id - csCmdLine.editContentsL .= (mv $ textZipper eLines Nothing) - csInputHistoryPosition.at cId .= (Just $ Just newI) + csEditState.cedEditor.editContentsL .= (mv $ textZipper eLines Nothing) + csEditState.cedInputHistoryPosition.at cId .= (Just $ Just newI) _ -> return () channelHistoryBackward :: MH () channelHistoryBackward = do cId <- use csCurrentChannelId - inputHistoryPos <- use (csInputHistoryPosition.at cId) - inputHistory <- use csInputHistory + inputHistoryPos <- use (csEditState.cedInputHistoryPosition.at cId) + inputHistory <- use (csEditState.cedInputHistory) case inputHistoryPos of Just (Just i) -> let newI = i + 1 @@ -1046,8 +1049,8 @@ Just entry -> do let eLines = T.lines entry mv = if length eLines == 1 then gotoEOL else id - csCmdLine.editContentsL .= (mv $ textZipper eLines Nothing) - csInputHistoryPosition.at cId .= (Just $ Just newI) + csEditState.cedEditor.editContentsL .= (mv $ textZipper eLines Nothing) + csEditState.cedInputHistoryPosition.at cId .= (Just $ Just newI) _ -> let newI = 0 in case getHistoryEntry cId newI inputHistory of @@ -1057,8 +1060,8 @@ mv = if length eLines == 1 then gotoEOL else id in do saveCurrentEdit - csCmdLine.editContentsL .= (mv $ textZipper eLines Nothing) - csInputHistoryPosition.at cId .= (Just $ Just newI) + csEditState.cedEditor.editContentsL .= (mv $ textZipper eLines Nothing) + csEditState.cedInputHistoryPosition.at cId .= (Just $ Just newI) showHelpScreen :: HelpTopic -> MH () showHelpScreen topic = do @@ -1192,7 +1195,7 @@ return False Just urlOpenCommand -> -- Is the URL referring to an attachment? - case _linkFileId link of + case link^.linkFileId of Nothing -> do openLink urlOpenCommand link return True @@ -1214,7 +1217,7 @@ openAttachment urlOpenCommand fId = do -- The link is for an attachment, so fetch it and then -- open the local copy. - sess <- use csSession + sess <- use (csResources.crSession) outputChan <- use (csResources.crSubprocessLog) doAsyncWith Preempt $ do info <- mmGetFileInfo sess fId @@ -1307,19 +1310,19 @@ case mode of NewPost -> do pendingPost <- mkPendingPost msg myId chanId - void $ mmPost (st^.csSession) theTeamId pendingPost + void $ mmPost (st^.csResources.crSession) theTeamId pendingPost Replying _ p -> do pendingPost <- mkPendingPost msg myId chanId let modifiedPost = pendingPost { pendingPostParentId = Just $ postId p , pendingPostRootId = Just $ postId p } - void $ mmPost (st^.csSession) theTeamId modifiedPost + void $ mmPost (st^.csResources.crSession) theTeamId modifiedPost Editing p -> do let modifiedPost = p { postMessage = msg , postPendingPostId = Nothing } - void $ mmUpdatePost (st^.csSession) theTeamId modifiedPost + void $ mmUpdatePost (st^.csResources.crSession) theTeamId modifiedPost handleNewUser :: UserId -> MH () handleNewUser newUserId = doAsyncMM Normal getUserInfo updateUserState diff --git a/src/State/Common.hs b/src/State/Common.hs --- a/src/State/Common.hs +++ b/src/State/Common.hs @@ -5,7 +5,7 @@ import qualified Control.Concurrent.STM as STM import Control.Exception (try) -import Control.Monad.IO.Class (MonadIO, liftIO) +import Control.Monad.IO.Class (liftIO) import qualified Data.Foldable as F import qualified Data.HashMap.Strict as HM import qualified Data.Map.Strict as Map @@ -13,7 +13,6 @@ import qualified Data.Sequence as Seq import qualified Data.Set as Set import qualified Data.Text as T -import Data.Time.Clock (getCurrentTime) import Lens.Micro.Platform import System.Hclip (setClipboard, ClipboardException(..)) @@ -96,62 +95,66 @@ -- front of the queue); normal means it will go last in the queue. data AsyncPriority = Preempt | Normal --- | Run a computation in the background, ignoring any results --- from it. +-- | Run a computation in the background, ignoring any results from it. doAsync :: AsyncPriority -> IO () -> MH () -doAsync prio thunk = doAsyncWith prio (thunk >> return (return ())) +doAsync prio act = doAsyncWith prio (act >> return (return ())) --- | Run a computation in the background, returning a computation --- to be called on the 'ChatState' value. +-- | Run a computation in the background, returning a computation to be +-- called on the 'ChatState' value. doAsyncWith :: AsyncPriority -> IO (MH ()) -> MH () -doAsyncWith prio thunk = do +doAsyncWith prio act = do let putChan = case prio of Preempt -> STM.unGetTChan Normal -> STM.writeTChan queue <- use (csResources.crRequestQueue) - liftIO $ STM.atomically $ putChan queue $ thunk + liftIO $ STM.atomically $ putChan queue act doAsyncIO :: AsyncPriority -> ChatState -> IO () -> IO () -doAsyncIO prio st thunk = - doAsyncWithIO prio st (thunk >> return (return ())) +doAsyncIO prio st act = + doAsyncWithIO prio st (act >> return (return ())) --- | Run a computation in the background, returning a computation --- to be called on the 'ChatState' value. +-- | Run a computation in the background, returning a computation to be +-- called on the 'ChatState' value. doAsyncWithIO :: AsyncPriority -> ChatState -> IO (MH ()) -> IO () -doAsyncWithIO prio st thunk = do +doAsyncWithIO prio st act = do let putChan = case prio of Preempt -> STM.unGetTChan Normal -> STM.writeTChan let queue = st^.csResources.crRequestQueue - STM.atomically $ putChan queue $ thunk + STM.atomically $ putChan queue act --- | Performs an asynchronous IO operation. On completion, the final --- argument a completion function is executed in an MH () context in --- the main (brick) thread. -doAsyncMM :: AsyncPriority -- ^ the priority for this async operation - -> (Session -> TeamId -> IO a) -- ^ the async MM channel-based IO operation - -> (a -> MH ()) -- ^ function to process the results in - -- brick event handling context +-- | Performs an asynchronous IO operation. On completion, the final +-- argument a completion function is executed in an MH () context in the +-- main (brick) thread. +doAsyncMM :: AsyncPriority + -- ^ the priority for this async operation + -> (Session -> TeamId -> IO a) + -- ^ the async MM channel-based IO operation + -> (a -> MH ()) + -- ^ function to process the results in brick event handling + -- context -> MH () -doAsyncMM prio mmOp thunk = do - session <- use csSession +doAsyncMM prio mmOp eventHandler = do + session <- use (csResources.crSession) myTeamId <- use (csMyTeam.teamIdL) doAsyncWith prio $ do r <- mmOp session myTeamId - return $ thunk r + return $ eventHandler r --- | Helper type for a function to perform an asynchronous MM --- operation on a channel and then invoke an MH completion event. -type DoAsyncChannelMM a - = AsyncPriority -- ^ the priority for this async operation - -> Maybe ChannelId -- ^ defaults to the "current" channel if Nothing - -> (Session -> TeamId -> ChannelId -> IO a) -- ^ the asynchronous Mattermost - -- channel-based IO operation - -> (ChannelId -> a -> MH ()) -- ^ function to process the results in brick - -- event handling context - -> MH () +-- | Helper type for a function to perform an asynchronous MM operation +-- on a channel and then invoke an MH completion event. +type DoAsyncChannelMM a = + AsyncPriority + -- ^ the priority for this async operation + -> Maybe ChannelId + -- ^ defaults to the "current" channel if Nothing + -> (Session -> TeamId -> ChannelId -> IO a) + -- ^ the asynchronous Mattermost channel-based IO operation + -> (ChannelId -> a -> MH ()) + -- ^ function to process the results in brick event handling context + -> MH () --- | Performs an asynchronous IO operation on a specific channel. On +-- | Performs an asynchronous IO operation on a specific channel. On -- completion, the final argument a completion function is executed in -- an MH () context in the main (brick) thread. -- @@ -159,10 +162,10 @@ -- the completion function is always called with the channel ID upon -- which the operation was performed. doAsyncChannelMM :: DoAsyncChannelMM a -doAsyncChannelMM prio m_cId mmOp thunk = do +doAsyncChannelMM prio m_cId mmOp eventHandler = do ccId <- use csCurrentChannelId let cId = maybe ccId id m_cId - doAsyncMM prio (\s t -> mmOp s t cId) (\r -> thunk cId r) + 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 @@ -170,7 +173,7 @@ -- function is called, no operations are performed (i.e., this request -- is treated as a duplicate). asPending :: DoAsyncChannelMM a -> DoAsyncChannelMM a -asPending asyncOp prio m_cId mmOp thunk = do +asPending asyncOp prio m_cId mmOp eventHandler = do ccId <- use csCurrentChannelId let cId = maybe ccId id m_cId withChannel cId $ \chan -> @@ -182,19 +185,7 @@ csChannel(cId).ccInfo.cdCurrentState .= pendState asyncOp prio m_cId mmOp $ \_ r -> do csChannel(cId).ccInfo.cdCurrentState %= setDone - thunk cId r - --- | Helper to skip the first 3 arguments of a 4 argument function -___1 :: (a -> b -> c -> d -> e) -> d -> (a -> b -> c -> e) -___1 f a = \s t c -> f s t c a - --- | Helper to skip the first 3 arguments of a 5 argument function -___2 :: (a -> b -> c -> d -> e -> g) -> d -> e -> (a -> b -> c -> g) -___2 f a b = \s t c -> f s t c a b - --- | Helper to skip the first 3 arguments of a 5 argument function -___3 :: (a -> b -> c -> d -> e -> g -> h) -> d -> e -> g -> (a -> b -> c -> h) -___3 f a b d = \s t c -> f s t c a b d + eventHandler cId r -- | Use this convenience function if no operation needs to be -- performed in the MH state after an async operation completes. @@ -247,17 +238,13 @@ asyncFetchAttachments p = do let cId = (p^.postChannelIdL) pId = (p^.postIdL) - session <- use csSession + session <- use (csResources.crSession) host <- use (csResources.crConn.cdHostnameL) F.forM_ (p^.postFileIdsL) $ \fId -> doAsyncWith Normal $ do info <- mmGetFileInfo session fId let scheme = "https://" attUrl = scheme <> host <> urlForFile fId - attachment = Attachment - { _attachmentName = fileInfoName info - , _attachmentURL = attUrl - , _attachmentFileId = fId - } + attachment = mkAttachment (fileInfoName info) attUrl fId addAttachment m | m^.mPostId == Just pId = m & mAttachments %~ (attachment Seq.<|) @@ -265,12 +252,6 @@ return $ csChannel(cId).ccContents.cdMessages.traversed %= addAttachment --- | Create a new 'ClientMessage' value -newClientMessage :: (MonadIO m) => ClientMessageType -> T.Text -> m ClientMessage -newClientMessage ty msg = do - now <- liftIO getCurrentTime - return (ClientMessage msg now ty) - -- | Add a 'ClientMessage' to the current channel's message list addClientMessage :: ClientMessage -> MH () addClientMessage msg = do @@ -306,7 +287,7 @@ asyncFetchReactionsForPost cId p | not (p^.postHasReactionsL) = return () | otherwise = doAsyncChannelMM Normal (Just cId) - (___1 mmGetReactionsForPost (p^.postIdL)) + (\s t c -> mmGetReactionsForPost s t c (p^.postIdL)) addReactions addReactions :: ChannelId -> [Reaction] -> MH () diff --git a/src/State/Editing.hs b/src/State/Editing.hs --- a/src/State/Editing.hs +++ b/src/State/Editing.hs @@ -56,7 +56,7 @@ Sys.withSystemTempFile "matterhorn_editor.tmp" $ \tmpFileName tmpFileHandle -> do -- Write the current message to the temp file Sys.hPutStr tmpFileHandle $ T.unpack $ T.intercalate "\n" $ - getEditContents $ st^.csCmdLine + getEditContents $ st^.csEditState.cedEditor Sys.hClose tmpFileHandle -- Run the editor @@ -72,7 +72,7 @@ postErrorMessageIO "Failed to decode file contents as UTF-8" st Right t -> do let tmpLines = T.lines t - return $ st & csCmdLine.editContentsL .~ (Z.textZipper tmpLines Nothing) + return $ st & csEditState.cedEditor.editContentsL .~ (Z.textZipper tmpLines Nothing) & csEditState.cedMultiline .~ (length tmpLines > 1) Sys.ExitFailure _ -> return st @@ -86,7 +86,7 @@ case findUserByName usrs uname of Just (uid, _) -> do cId <- use csCurrentChannelId - session <- use csSession + session <- use (csResources.crSession) myTeamId <- use (csMyTeam.teamIdL) doAsyncWith Normal $ do tryMM (void $ mmChannelAddUser session myTeamId cId uid) @@ -97,59 +97,59 @@ handlePaste :: BS.ByteString -> MH () handlePaste bytes = do let pasteStr = T.pack (UTF8.toString bytes) - csCmdLine %= applyEdit (Z.insertMany pasteStr) - contents <- use (csCmdLine.to getEditContents) + csEditState.cedEditor %= applyEdit (Z.insertMany pasteStr) + contents <- use (csEditState.cedEditor.to getEditContents) case length contents > 1 of True -> startMultilineEditing False -> return () editingPermitted :: ChatState -> Bool editingPermitted st = - (length (getEditContents $ st^.csCmdLine) == 1) || + (length (getEditContents $ st^.csEditState.cedEditor) == 1) || st^.csEditState.cedMultiline editingKeybindings :: [Keybinding] editingKeybindings = [ KB "Transpose the final two characters" (EvKey (KChar 't') [MCtrl]) $ do - csCmdLine %= applyEdit Z.transposeChars + csEditState.cedEditor %= applyEdit Z.transposeChars , KB "Move one character to the right" (EvKey (KChar 'f') [MCtrl]) $ do - csCmdLine %= applyEdit Z.moveRight + csEditState.cedEditor %= applyEdit Z.moveRight , KB "Move one character to the left" (EvKey (KChar 'b') [MCtrl]) $ do - csCmdLine %= applyEdit Z.moveLeft + csEditState.cedEditor %= applyEdit Z.moveLeft , KB "Move one word to the right" (EvKey (KChar 'f') [MMeta]) $ do - csCmdLine %= applyEdit Z.moveWordRight + csEditState.cedEditor %= applyEdit Z.moveWordRight , KB "Move one word to the left" (EvKey (KChar 'b') [MMeta]) $ do - csCmdLine %= applyEdit Z.moveWordLeft + csEditState.cedEditor %= applyEdit Z.moveWordLeft , KB "Delete the word to the left of the cursor" (EvKey (KBS) [MMeta]) $ do - csCmdLine %= applyEdit Z.deletePrevWord + csEditState.cedEditor %= applyEdit Z.deletePrevWord , KB "Delete the word to the left of the cursor" (EvKey (KChar 'w') [MCtrl]) $ do - csCmdLine %= applyEdit Z.deletePrevWord + csEditState.cedEditor %= applyEdit Z.deletePrevWord , KB "Delete the word to the right of the cursor" (EvKey (KChar 'd') [MMeta]) $ do - csCmdLine %= applyEdit Z.deleteWord + csEditState.cedEditor %= applyEdit Z.deleteWord , KB "Move the cursor to the beginning of the input" (EvKey KHome []) $ do - csCmdLine %= applyEdit gotoHome + csEditState.cedEditor %= applyEdit gotoHome , KB "Move the cursor to the end of the input" (EvKey KEnd []) $ do - csCmdLine %= applyEdit gotoEnd + csEditState.cedEditor %= applyEdit gotoEnd , KB "Kill the line to the right of the current position and copy it" (EvKey (KChar 'k') [MCtrl]) $ do - z <- use (csCmdLine.editContentsL) + z <- use (csEditState.cedEditor.editContentsL) let restOfLine = Z.currentLine (Z.killToBOL z) csEditState.cedYankBuffer .= restOfLine - csCmdLine %= applyEdit Z.killToEOL + csEditState.cedEditor %= applyEdit Z.killToEOL , KB "Paste the current buffer contents at the cursor" (EvKey (KChar 'y') [MCtrl]) $ do buf <- use (csEditState.cedYankBuffer) - csCmdLine %= applyEdit (Z.insertMany buf) + csEditState.cedEditor %= applyEdit (Z.insertMany buf) ] handleEditingInput :: Event -> MH () @@ -171,39 +171,39 @@ -- Not editing; backspace here means cancel multi-line message -- composition EvKey KBS [] | (not $ editingPermitted st) -> - csCmdLine %= applyEdit Z.clearZipper + csEditState.cedEditor %= applyEdit Z.clearZipper -- Backspace in editing mode with smart pair insertion means -- smart pair removal when possible EvKey KBS [] | editingPermitted st && smartBacktick -> - let backspace = csCmdLine %= applyEdit Z.deletePrevChar - in case cursorAtOneOf smartChars (st^.csCmdLine) of + let backspace = csEditState.cedEditor %= applyEdit Z.deletePrevChar + in case cursorAtOneOf smartChars (st^.csEditState.cedEditor) of Nothing -> backspace Just ch -> -- Smart char removal: - if | (cursorAtChar ch $ applyEdit Z.moveLeft $ st^.csCmdLine) && - (cursorIsAtEnd $ applyEdit Z.moveRight $ st^.csCmdLine) -> - csCmdLine %= applyEdit (Z.deleteChar >>> Z.deletePrevChar) + if | (cursorAtChar ch $ applyEdit Z.moveLeft $ st^.csEditState.cedEditor) && + (cursorIsAtEnd $ applyEdit Z.moveRight $ st^.csEditState.cedEditor) -> + csEditState.cedEditor %= applyEdit (Z.deleteChar >>> Z.deletePrevChar) | otherwise -> backspace EvKey (KChar ch) [] | editingPermitted st && smartBacktick && ch `elem` smartChars -> -- Smart char insertion: - let doInsertChar = csCmdLine %= applyEdit (Z.insertChar ch) - in if | (editorEmpty $ st^.csCmdLine) || - ((cursorAtChar ' ' (applyEdit Z.moveLeft $ st^.csCmdLine)) && - (cursorIsAtEnd $ st^.csCmdLine)) -> - csCmdLine %= applyEdit (Z.insertMany (T.pack $ ch:ch:[]) >>> Z.moveLeft) - | (cursorAtChar ch $ st^.csCmdLine) && - (cursorIsAtEnd $ applyEdit Z.moveRight $ st^.csCmdLine) -> - csCmdLine %= applyEdit Z.moveRight + let doInsertChar = csEditState.cedEditor %= applyEdit (Z.insertChar ch) + in if | (editorEmpty $ st^.csEditState.cedEditor) || + ((cursorAtChar ' ' (applyEdit Z.moveLeft $ st^.csEditState.cedEditor)) && + (cursorIsAtEnd $ st^.csEditState.cedEditor)) -> + csEditState.cedEditor %= applyEdit (Z.insertMany (T.pack $ ch:ch:[]) >>> Z.moveLeft) + | (cursorAtChar ch $ st^.csEditState.cedEditor) && + (cursorIsAtEnd $ applyEdit Z.moveRight $ st^.csEditState.cedEditor) -> + csEditState.cedEditor %= applyEdit Z.moveRight | otherwise -> doInsertChar - _ | editingPermitted st -> mhHandleEventLensed csCmdLine handleEditorEvent e + _ | editingPermitted st -> mhHandleEventLensed (csEditState.cedEditor) handleEditorEvent e | otherwise -> return () - csCurrentCompletion .= Nothing + csEditState.cedCurrentCompletion .= Nothing - liftIO $ st^.csEditState.cedResetSpellCheckTimer + liftIO $ resetSpellCheckTimer $ st^.csEditState -- Kick off an async request to the spell checker for the current editor -- contents. @@ -212,10 +212,10 @@ st <- use id case st^.csEditState.cedSpellChecker of Nothing -> return () - Just checker -> do + Just (checker, _) -> do -- Get the editor contents. - contents <- getEditContents <$> use csCmdLine - doAsyncWith Normal $ do + contents <- getEditContents <$> use (csEditState.cedEditor) + doAsyncWith Preempt $ do -- For each line in the editor, submit an aspell request. let query = concat <$> mapM (askAspell checker) contents postMistakes :: [AspellResponse] -> MH () diff --git a/src/State/PostListOverlay.hs b/src/State/PostListOverlay.hs --- a/src/State/PostListOverlay.hs +++ b/src/State/PostListOverlay.hs @@ -28,7 +28,7 @@ -- server. enterFlaggedPostListMode :: MH () enterFlaggedPostListMode = do - session <- use csSession + session <- use (csResources.crSession) uId <- use (csMe.userIdL) doAsyncWith Preempt $ do posts <- mmGetFlaggedPosts session uId diff --git a/src/State/Setup.hs b/src/State/Setup.hs --- a/src/State/Setup.hs +++ b/src/State/Setup.hs @@ -6,27 +6,19 @@ import Prelude.Compat import Brick.BChan -import Brick.Widgets.List (list) -import Control.Concurrent (threadDelay, forkIO) import qualified Control.Concurrent.STM as STM -import Control.Concurrent.STM.Delay import Control.Concurrent.MVar (newEmptyMVar) -import Control.Exception (SomeException, catch, try) -import Control.Monad (forM, forever, when, void) -import qualified Data.Text as T +import Control.Exception (catch) +import Control.Monad (forM, when) import qualified Data.Foldable as F import qualified Data.HashMap.Strict as HM -import Data.List (sort) -import Data.Maybe (listToMaybe, maybeToList, fromJust, catMaybes) +import Data.Maybe (listToMaybe, maybeToList, fromJust) import Data.Monoid ((<>)) import qualified Data.Sequence as Seq -import Data.Time.LocalTime ( TimeZone(..), getCurrentTimeZone ) +import Data.Time.LocalTime (getCurrentTimeZone) import Lens.Micro.Platform -import System.Exit (exitFailure, ExitCode(ExitSuccess)) -import System.IO (Handle, hPutStrLn, hFlush) -import System.IO.Temp (openTempFile) -import System.Directory (getTemporaryDirectory) -import Text.Aspell (Aspell, AspellOption(..), startAspell) +import System.Exit (exitFailure) +import System.IO (Handle) import Network.Mattermost import Network.Mattermost.Lenses @@ -37,150 +29,14 @@ import Login import State (updateMessageFlag) import State.Common -import State.Editing (requestSpellCheck) import TeamSelect import Themes +import State.Setup.Threads import Types import Types.Channels import Types.Users -import Zipper (Zipper) import qualified Zipper as Z -updateUserStatuses :: Session -> IO (MH ()) -updateUserStatuses session = do - statusMap <- mmGetStatuses session - return $ do - let setStatus u = u & uiStatus .~ (newsts u) - newsts u = (statusMap^.at(u^.uiId) & _Just %~ statusFromText) ^. non Offline - csUsers . mapped %= setStatus - -userRefresh :: Session -> RequestChan -> IO () -userRefresh session requestChan = void $ forkIO $ forever refresh - where refresh = do - let seconds = (* (1000 * 1000)) - threadDelay (seconds 30) - STM.atomically $ STM.writeTChan requestChan $ do - rs <- try $ updateUserStatuses session - case rs of - Left (_ :: SomeException) -> return (return ()) - Right upd -> return upd - -startSubprocessLogger :: STM.TChan ProgramOutput -> RequestChan -> IO () -startSubprocessLogger logChan requestChan = do - let logMonitor mPair = do - ProgramOutput progName args out stdoutOkay err ec <- - STM.atomically $ STM.readTChan logChan - - -- If either stdout or stderr is non-empty or there was an exit - -- failure, log it and notify the user. - let emptyOutput s = null s || s == "\n" - - case ec == ExitSuccess && (emptyOutput out || stdoutOkay) && emptyOutput err of - -- the "good" case, no output and exit sucess - True -> logMonitor mPair - False -> do - (logPath, logHandle) <- case mPair of - Just p -> - return p - Nothing -> do - tmp <- getTemporaryDirectory - openTempFile tmp "matterhorn-subprocess.log" - - hPutStrLn logHandle $ - unlines [ "Program: " <> progName - , "Arguments: " <> show args - , "Exit code: " <> show ec - , "Stdout:" - , out - , "Stderr:" - , err - ] - hFlush logHandle - - STM.atomically $ STM.writeTChan requestChan $ do - return $ do - let msg = T.pack $ - "An error occurred when running " <> show progName <> - "; see " <> logPath <> " for details." - postErrorMessage msg - - logMonitor (Just (logPath, logHandle)) - - void $ forkIO $ logMonitor Nothing - -startTimezoneMonitor :: TimeZone -> RequestChan -> IO () -startTimezoneMonitor tz requestChan = do - -- Start the timezone monitor thread - let timezoneMonitorSleepInterval = minutes 5 - minutes = (* (seconds 60)) - seconds = (* (1000 * 1000)) - timezoneMonitor prevTz = do - threadDelay timezoneMonitorSleepInterval - - newTz <- getCurrentTimeZone - when (newTz /= prevTz) $ - STM.atomically $ STM.writeTChan requestChan $ do - return $ timeZone .= newTz - - timezoneMonitor newTz - - void $ forkIO (timezoneMonitor tz) - -mkChanNames :: User -> HM.HashMap UserId User -> Seq.Seq Channel -> MMNames -mkChanNames myUser users chans = MMNames - { _cnChans = sort - [ preferredChannelName c - | c <- F.toList chans, channelType c /= Direct ] - , _cnDMs = sort - [ channelName c - | c <- F.toList chans, channelType c == Direct ] - , _cnToChanId = HM.fromList $ - [ (preferredChannelName c, channelId c) | c <- F.toList chans ] ++ - [ (userUsername u, c) - | u <- HM.elems users - , c <- lookupChan (getDMChannelName (getId myUser) (getId u)) - ] - , _cnUsers = sort (map userUsername (HM.elems users)) - , _cnToUserId = HM.fromList - [ (userUsername u, getId u) | u <- HM.elems users ] - } - where lookupChan n = [ c^.channelIdL - | c <- F.toList chans, c^.channelNameL == n - ] - -newState :: ChatResources - -> Zipper ChannelId - -> User - -> Team - -> TimeZone - -> InputHistory - -> Maybe Aspell - -> IO () - -> ChatState -newState rs i u m tz hist sp resetTimer = ChatState - { _csResources = rs - , _csFocus = i - , _csMe = u - , _csMyTeam = m - , _csNames = emptyMMNames - , _csChannels = noChannels - , _csPostMap = HM.empty - , _csUsers = noUsers - , _timeZone = tz - , _csEditState = emptyEditState hist sp resetTimer - , _csMode = Main - , _csShowMessagePreview = configShowMessagePreview $ rs^.crConfiguration - , _csChannelSelectString = "" - , _csChannelSelectChannelMatches = mempty - , _csChannelSelectUserMatches = mempty - , _csRecentChannel = Nothing - , _csUrlList = list UrlList mempty 2 - , _csConnectionStatus = Connected - , _csJoinChannelList = Nothing - , _csMessageSelect = MessageSelectState Nothing - , _csPostListOverlay = PostListOverlayState mempty Nothing - } - loadFlaggedMessages :: ChatState -> IO () loadFlaggedMessages st = doAsyncWithIO Normal st $ do prefs <- mmGetMyPreferences (st^.csResources.crSession) @@ -201,9 +57,18 @@ Just f -> \ cd -> cd `withLogger` mmLoggerDebug f let loginLoop cInfo = do - cd <- setLogger `fmap` - initConnectionData (ciHostname cInfo) - (fromIntegral (ciPort cInfo)) + cd <- fmap setLogger $ + -- we don't implement HTTP fallback right now, we just + -- go straight for HTTP if someone has indicated that + -- they want it. We probably should in the future + -- always try HTTPS first, and then, if the + -- configuration option is there, try falling back to + -- HTTP. + if (configUnsafeUseHTTP config) + then initConnectionDataInsecure (ciHostname cInfo) + (fromIntegral (ciPort cInfo)) + else initConnectionData (ciHostname cInfo) + (fromIntegral (ciPort cInfo)) let login = Login { username = ciUsername cInfo , password = ciPassword cInfo @@ -259,17 +124,8 @@ theme = case lookup themeName themes of Nothing -> fromJust $ lookup defaultThemeName themes Just t -> t - cr = ChatResources - { _crSession = session - , _crConn = cd - , _crRequestQueue = requestChan - , _crEventQueue = eventChan - , _crTheme = theme - , _crQuitCondition = quitCondition - , _crConfiguration = config - , _crSubprocessLog = slc - , _crFlaggedPosts = mempty - } + cr = ChatResources session cd requestChan eventChan + slc theme quitCondition config mempty initializeState cr myTeam myUser loadAllUsers :: Session -> IO (HM.HashMap UserId User) @@ -282,13 +138,10 @@ initializeState :: ChatResources -> Team -> User -> IO ChatState initializeState cr myTeam myUser = do - let ChatResources session _ requestChan _ _ _ _ _ _ = cr + let session = cr^.crSession + requestChan = cr^.crRequestQueue let myTeamId = getId myTeam - STM.atomically $ STM.writeTChan requestChan $ updateUserStatuses session - - userRefresh session requestChan - chans <- mmGetChannels session myTeamId msgs <- forM (F.toList chans) $ \c -> do @@ -308,21 +161,15 @@ Left _ -> return newHistory Right h -> return h - startTimezoneMonitor tz requestChan - - startSubprocessLogger (cr^.crSubprocessLog) requestChan - - -- Start the spell check timer thread. - let spellCheckerTimeout = 500 * 1000 -- 500k us = 500ms - resetSCChan <- startSpellCheckerThread (cr^.crEventQueue) spellCheckerTimeout - let resetSCTimer = STM.atomically $ STM.writeTChan resetSCChan () - - sp <- case configEnableAspell $ cr^.crConfiguration of - False -> return Nothing - True -> - let aspellOpts = catMaybes [ UseDictionary <$> (configAspellDictionary $ cr^.crConfiguration) - ] - in either (const Nothing) Just <$> startAspell aspellOpts + -- Start background worker threads: + -- * User status refresher + startUserRefreshThread session requestChan + -- * Timezone change monitor + startTimezoneMonitorThread tz requestChan + -- * Subprocess logger + startSubprocessLoggerThread (cr^.crSubprocessLog) requestChan + -- * Spell checker and spell check timer, if configured + spResult <- maybeStartSpellChecker (cr^.crConfiguration) (cr^.crEventQueue) let chanNames = mkChanNames myUser users chans Just townSqId = chanNames ^. cnToChanId . at "town-square" @@ -332,82 +179,10 @@ | i <- chanNames ^. cnUsers , c <- maybeToList (HM.lookup i (chanNames ^. cnToChanId)) ] chanZip = Z.findRight (== townSqId) (Z.fromList chanIds) - st = newState cr chanZip myUser myTeam tz hist sp resetSCTimer + st = newState cr chanZip myUser myTeam tz hist spResult & csUsers %~ flip (foldr (uncurry addUser)) (fmap mkUser users) & csChannels %~ flip (foldr (uncurry addChannel)) msgs & csNames .~ chanNames loadFlaggedMessages st return st - --- Start the background spell checker delay thread. --- --- The purpose of this thread is to postpone the spell checker query --- while the user is actively typing and only wait until they have --- stopped typing before bothering with a query. This is to avoid spell --- checker queries when the editor contents are changing rapidly. --- Avoiding such queries reduces system load and redraw frequency. --- --- We do this by starting a thread whose job is to wait for the event --- loop to tell it to schedule a spell check. Spell checks are scheduled --- by writing to the channel returned by this function. The scheduler --- thread reads from that channel and then works with another worker --- thread as follows: --- --- A wakeup of the main spell checker thread causes it to determine --- whether the worker thread is already waiting on a timer. When that --- timer goes off, a spell check will be requested. If there is already --- an active timer that has not yet expired, the timer's expiration is --- extended. This is the case where typing is occurring and we want to --- continue postponing the spell check. If there is not an active timer --- or the active timer has expired, we create a new timer and send it to --- the worker thread for waiting. --- --- The worker thread works by reading a timer from its queue, waiting --- until the timer expires, and then injecting an event into the main --- event loop to request a spell check. -startSpellCheckerThread :: BChan MHEvent - -- ^ The main event loop's event channel. - -> Int - -- ^ The number of microseconds to wait before - -- requesting a spell check. - -> IO (STM.TChan ()) -startSpellCheckerThread eventChan spellCheckTimeout = do - delayWakeupChan <- STM.atomically STM.newTChan - delayWorkerChan <- STM.atomically STM.newTChan - delVar <- STM.atomically $ STM.newTVar Nothing - - -- The delay worker actually waits on the delay to expire and then - -- requests a spell check. - void $ forkIO $ forever $ do - STM.atomically $ waitDelay =<< STM.readTChan delayWorkerChan - writeBChan eventChan (RespEvent requestSpellCheck) - - -- The delay manager waits for requests to start a delay timer and - -- signals the worker to begin waiting. - void $ forkIO $ forever $ do - () <- STM.atomically $ STM.readTChan delayWakeupChan - - oldDel <- STM.atomically $ STM.readTVar delVar - mNewDel <- case oldDel of - Nothing -> Just <$> newDelay spellCheckTimeout - Just del -> do - -- It's possible that between this check for expiration and - -- the updateDelay below, the timer will expire -- at which - -- point this will mean that we won't extend the timer as - -- originally desired. But that's alright, because future - -- keystroke will trigger another timer anyway. - expired <- tryWaitDelayIO del - case expired of - True -> Just <$> newDelay spellCheckTimeout - False -> do - updateDelay del spellCheckTimeout - return Nothing - - case mNewDel of - Nothing -> return () - Just newDel -> STM.atomically $ do - STM.writeTVar delVar $ Just newDel - STM.writeTChan delayWorkerChan newDel - - return delayWakeupChan diff --git a/src/State/Setup/Threads.hs b/src/State/Setup/Threads.hs new file mode 100644 --- /dev/null +++ b/src/State/Setup/Threads.hs @@ -0,0 +1,204 @@ +module State.Setup.Threads + ( startUserRefreshThread + , startSubprocessLoggerThread + , startTimezoneMonitorThread + , maybeStartSpellChecker + ) +where + +import Prelude () +import Prelude.Compat + +import Brick.BChan +import Control.Concurrent (threadDelay, forkIO) +import qualified Control.Concurrent.STM as STM +import Control.Concurrent.STM.Delay +import Control.Exception (SomeException, try) +import Control.Monad (forever, when, void) +import qualified Data.Text as T +import Data.Maybe (catMaybes) +import Data.Monoid ((<>)) +import Data.Time.LocalTime ( TimeZone(..), getCurrentTimeZone ) +import Lens.Micro.Platform +import System.Exit (ExitCode(ExitSuccess)) +import System.IO (hPutStrLn, hFlush) +import System.IO.Temp (openTempFile) +import System.Directory (getTemporaryDirectory) +import Text.Aspell (Aspell, AspellOption(..), startAspell) + +import Network.Mattermost + +import State.Common +import State.Editing (requestSpellCheck) +import Types +import Types.Users + +updateUserStatuses :: Session -> IO (MH ()) +updateUserStatuses session = do + statusMap <- mmGetStatuses session + return $ do + let setStatus u = u & uiStatus .~ (newsts u) + newsts u = (statusMap^.at(u^.uiId) & _Just %~ statusFromText) ^. non Offline + csUsers . mapped %= setStatus + +startUserRefreshThread :: Session -> RequestChan -> IO () +startUserRefreshThread session requestChan = void $ forkIO $ forever refresh + where + seconds = (* (1000 * 1000)) + userRefreshInterval = 30 + refresh = do + STM.atomically $ STM.writeTChan requestChan $ do + rs <- try $ updateUserStatuses session + case rs of + Left (_ :: SomeException) -> return (return ()) + Right upd -> return upd + threadDelay (seconds userRefreshInterval) + +startSubprocessLoggerThread :: STM.TChan ProgramOutput -> RequestChan -> IO () +startSubprocessLoggerThread logChan requestChan = do + let logMonitor mPair = do + ProgramOutput progName args out stdoutOkay err ec <- + STM.atomically $ STM.readTChan logChan + + -- If either stdout or stderr is non-empty or there was an exit + -- failure, log it and notify the user. + let emptyOutput s = null s || s == "\n" + + case ec == ExitSuccess && (emptyOutput out || stdoutOkay) && emptyOutput err of + -- the "good" case, no output and exit sucess + True -> logMonitor mPair + False -> do + (logPath, logHandle) <- case mPair of + Just p -> + return p + Nothing -> do + tmp <- getTemporaryDirectory + openTempFile tmp "matterhorn-subprocess.log" + + hPutStrLn logHandle $ + unlines [ "Program: " <> progName + , "Arguments: " <> show args + , "Exit code: " <> show ec + , "Stdout:" + , out + , "Stderr:" + , err + ] + hFlush logHandle + + STM.atomically $ STM.writeTChan requestChan $ do + return $ do + let msg = T.pack $ + "An error occurred when running " <> show progName <> + "; see " <> logPath <> " for details." + postErrorMessage msg + + logMonitor (Just (logPath, logHandle)) + + void $ forkIO $ logMonitor Nothing + +startTimezoneMonitorThread :: TimeZone -> RequestChan -> IO () +startTimezoneMonitorThread tz requestChan = do + -- Start the timezone monitor thread + let timezoneMonitorSleepInterval = minutes 5 + minutes = (* (seconds 60)) + seconds = (* (1000 * 1000)) + timezoneMonitor prevTz = do + threadDelay timezoneMonitorSleepInterval + + newTz <- getCurrentTimeZone + when (newTz /= prevTz) $ + STM.atomically $ STM.writeTChan requestChan $ do + return $ timeZone .= newTz + + timezoneMonitor newTz + + void $ forkIO (timezoneMonitor tz) + +maybeStartSpellChecker :: Config -> BChan MHEvent -> IO (Maybe (Aspell, IO ())) +maybeStartSpellChecker config eventQueue = do + case configEnableAspell config of + False -> return Nothing + True -> do + let aspellOpts = catMaybes [ UseDictionary <$> (configAspellDictionary config) + ] + spellCheckerTimeout = 500 * 1000 -- 500k us = 500ms + asResult <- either (const Nothing) Just <$> startAspell aspellOpts + case asResult of + Nothing -> return Nothing + Just as -> do + resetSCChan <- startSpellCheckerThread eventQueue spellCheckerTimeout + let resetSCTimer = STM.atomically $ STM.writeTChan resetSCChan () + return $ Just (as, resetSCTimer) + +-- Start the background spell checker delay thread. +-- +-- The purpose of this thread is to postpone the spell checker query +-- while the user is actively typing and only wait until they have +-- stopped typing before bothering with a query. This is to avoid spell +-- checker queries when the editor contents are changing rapidly. +-- Avoiding such queries reduces system load and redraw frequency. +-- +-- We do this by starting a thread whose job is to wait for the event +-- loop to tell it to schedule a spell check. Spell checks are scheduled +-- by writing to the channel returned by this function. The scheduler +-- thread reads from that channel and then works with another worker +-- thread as follows: +-- +-- A wakeup of the main spell checker thread causes it to determine +-- whether the worker thread is already waiting on a timer. When that +-- timer goes off, a spell check will be requested. If there is already +-- an active timer that has not yet expired, the timer's expiration is +-- extended. This is the case where typing is occurring and we want to +-- continue postponing the spell check. If there is not an active timer +-- or the active timer has expired, we create a new timer and send it to +-- the worker thread for waiting. +-- +-- The worker thread works by reading a timer from its queue, waiting +-- until the timer expires, and then injecting an event into the main +-- event loop to request a spell check. +startSpellCheckerThread :: BChan MHEvent + -- ^ The main event loop's event channel. + -> Int + -- ^ The number of microseconds to wait before + -- requesting a spell check. + -> IO (STM.TChan ()) +startSpellCheckerThread eventChan spellCheckTimeout = do + delayWakeupChan <- STM.atomically STM.newTChan + delayWorkerChan <- STM.atomically STM.newTChan + delVar <- STM.atomically $ STM.newTVar Nothing + + -- The delay worker actually waits on the delay to expire and then + -- requests a spell check. + void $ forkIO $ forever $ do + STM.atomically $ waitDelay =<< STM.readTChan delayWorkerChan + writeBChan eventChan (RespEvent requestSpellCheck) + + -- The delay manager waits for requests to start a delay timer and + -- signals the worker to begin waiting. + void $ forkIO $ forever $ do + () <- STM.atomically $ STM.readTChan delayWakeupChan + + oldDel <- STM.atomically $ STM.readTVar delVar + mNewDel <- case oldDel of + Nothing -> Just <$> newDelay spellCheckTimeout + Just del -> do + -- It's possible that between this check for expiration and + -- the updateDelay below, the timer will expire -- at which + -- point this will mean that we won't extend the timer as + -- originally desired. But that's alright, because future + -- keystroke will trigger another timer anyway. + expired <- tryWaitDelayIO del + case expired of + True -> Just <$> newDelay spellCheckTimeout + False -> do + updateDelay del spellCheckTimeout + return Nothing + + case mNewDel of + Nothing -> return () + Just newDel -> STM.atomically $ do + STM.writeTVar delVar $ Just newDel + STM.writeTChan delayWorkerChan newDel + + return delayWakeupChan diff --git a/src/Types.hs b/src/Types.hs --- a/src/Types.hs +++ b/src/Types.hs @@ -4,9 +4,129 @@ {-# LANGUAGE MultiWayIf #-} {-# LANGUAGE RankNTypes #-} {-# LANGUAGE MultiParamTypeClasses #-} +module Types + ( ConnectionStatus(..) + , HelpTopic(..) + , MessageSelectState(..) + , ProgramOutput(..) + , MHEvent(..) + , Name(..) + , ChannelSelectMatch(..) + , ConnectionInfo(..) + , Config(..) + , HelpScreen(..) + , PasswordSource(..) + , MatchType(..) + , EditMode(..) + , Mode(..) + , ChannelSelectPattern(..) + , PostListContents(..) + , ChannelSelectMap + , AuthenticationException(..) + , BackgroundInfo(..) + , RequestChan -module Types where + , MMNames + , mkChanNames + , cnUsers + , cnToUserId + , cnToChanId + , cnChans + , LinkChoice(LinkChoice) + , linkUser + , linkURL + , linkTime + , linkName + , linkFileId + + , ChatState + , newState + , csResources + , csFocus + , csCurrentChannel + , csCurrentChannelId + , csUrlList + , csShowMessagePreview + , csPostMap + , csRecentChannel + , csPostListOverlay + , csMyTeam + , csMode + , csMessageSelect + , csJoinChannelList + , csConnectionStatus + , csWorkerIsBusy + , csNames + , csUsers + , csChannel + , csChannels + , csChannelSelectUserMatches + , csChannelSelectChannelMatches + , csChannelSelectString + , csMe + , csEditState + , timeZone + + , ChatEditState + , emptyEditState + , cedYankBuffer + , cedSpellChecker + , cedMisspellings + , cedEditMode + , cedCompletionAlternatives + , cedCurrentCompletion + , cedEditor + , cedCurrentAlternative + , cedMultiline + , cedInputHistory + , cedInputHistoryPosition + , cedLastChannelInput + + , PostListOverlayState + , postListSelected + , postListPosts + + , ChatResources(ChatResources) + , crEventQueue + , crTheme + , crSession + , crSubprocessLog + , crRequestQueue + , crQuitCondition + , crFlaggedPosts + , crConn + , crConfiguration + + , Cmd(..) + , commandName + , CmdArgs(..) + + , Keybinding(..) + , lookupKeybinding + + , MH + , runMHEvent + , mh + , mhSuspendAndResume + , mhHandleEventLensed + + , requestQuit + , clientPostToMessage + , getMessageForPostId + , resetSpellCheckTimer + , withChannel + , withChannelOrDefault + , userList + , hasUnread + , channelNameFromMatch + , isMine + + , userSigil + , normalChannelSigil + ) +where + import Prelude () import Prelude.Compat @@ -15,24 +135,25 @@ import Brick.BChan import Brick.AttrMap (AttrMap) import Brick.Widgets.Edit (Editor, editor) -import Brick.Widgets.List (List) +import Brick.Widgets.List (List, list) import qualified Control.Concurrent.STM as STM import Control.Concurrent.MVar (MVar) import Control.Exception (SomeException) import qualified Control.Monad.State as St +import qualified Data.Foldable as F +import qualified Data.Sequence as Seq import qualified Data.Set as S import Data.HashMap.Strict (HashMap) import Data.Time.Clock (UTCTime) import Data.Time.LocalTime (TimeZone) import qualified Data.HashMap.Strict as HM -import Data.List (partition, sortBy) +import Data.List (sort) import Data.Maybe import Data.Monoid import Data.Set (Set) import qualified Graphics.Vty as Vty import Lens.Micro.Platform ( at, makeLenses, lens, (&), (^.), (%~), (.~), (^?!) - , to, SimpleGetter, _Just - , Traversal', preuse ) + , _Just, Traversal', preuse ) import Network.Mattermost import Network.Mattermost.Exceptions import Network.Mattermost.Lenses @@ -74,18 +195,21 @@ , configSmartBacktick :: Bool , configURLOpenCommand :: Maybe T.Text , configActivityBell :: Bool + , configShowBackground :: BackgroundInfo , configShowMessagePreview :: Bool , configEnableAspell :: Bool , configAspellDictionary :: Maybe T.Text + , configUnsafeUseHTTP :: Bool } deriving (Eq, Show) +data BackgroundInfo = Disabled | Active | ActiveCount deriving (Eq, Show) + -- * 'MMNames' structures -- | The 'MMNames' record is for listing human-readable -- names and mapping them back to internal IDs. data MMNames = MMNames { _cnChans :: [T.Text] -- ^ All channel names - , _cnDMs :: [T.Text] -- ^ All DM channel names , _cnToChanId :: HashMap T.Text ChannelId -- ^ Mapping from channel names to 'ChannelId' values , _cnUsers :: [T.Text] -- ^ All users @@ -95,8 +219,27 @@ -- | An empty 'MMNames' record emptyMMNames :: MMNames -emptyMMNames = MMNames mempty mempty mempty mempty mempty +emptyMMNames = MMNames mempty mempty mempty mempty +mkChanNames :: User -> HM.HashMap UserId User -> Seq.Seq Channel -> MMNames +mkChanNames myUser users chans = MMNames + { _cnChans = sort + [ preferredChannelName c + | c <- F.toList chans, channelType c /= Direct ] + , _cnToChanId = HM.fromList $ + [ (preferredChannelName c, channelId c) | c <- F.toList chans ] ++ + [ (userUsername u, c) + | u <- HM.elems users + , c <- lookupChan (getDMChannelName (getId myUser) (getId u)) + ] + , _cnUsers = sort (map userUsername (HM.elems users)) + , _cnToUserId = HM.fromList + [ (userUsername u, getId u) | u <- HM.elems users ] + } + where lookupChan n = [ c^.channelIdL + | c <- F.toList chans, c^.channelNameL == n + ] + -- ** 'MMNames' Lenses makeLenses ''MMNames @@ -226,8 +369,7 @@ , _cedCurrentAlternative :: T.Text , _cedCompletionAlternatives :: [T.Text] , _cedYankBuffer :: T.Text - , _cedSpellChecker :: Maybe Aspell - , _cedResetSpellCheckTimer :: IO () + , _cedSpellChecker :: Maybe (Aspell, IO ()) , _cedMisspellings :: S.Set T.Text } @@ -239,8 +381,8 @@ -- | We can initialize a new 'ChatEditState' value with just an -- edit history, which we save locally. -emptyEditState :: InputHistory -> Maybe Aspell -> IO () -> ChatEditState -emptyEditState hist sp resetTimer = ChatEditState +emptyEditState :: InputHistory -> Maybe (Aspell, IO ()) -> ChatEditState +emptyEditState hist sp = ChatEditState { _cedEditor = editor MessageInput Nothing "" , _cedMultiline = False , _cedInputHistory = hist @@ -253,7 +395,6 @@ , _cedYankBuffer = "" , _cedSpellChecker = sp , _cedMisspellings = mempty - , _cedResetSpellCheckTimer = resetTimer } -- | A 'RequestChan' is a queue of operations we have to perform @@ -323,11 +464,45 @@ , _csRecentChannel :: Maybe ChannelId , _csUrlList :: List Name LinkChoice , _csConnectionStatus :: ConnectionStatus + , _csWorkerIsBusy :: Maybe (Maybe Int) , _csJoinChannelList :: Maybe (List Name Channel) , _csMessageSelect :: MessageSelectState , _csPostListOverlay :: PostListOverlayState } +newState :: ChatResources + -> Zipper ChannelId + -> User + -> Team + -> TimeZone + -> InputHistory + -> Maybe (Aspell, IO ()) + -> ChatState +newState rs i u m tz hist sp = ChatState + { _csResources = rs + , _csFocus = i + , _csMe = u + , _csMyTeam = m + , _csNames = emptyMMNames + , _csChannels = noChannels + , _csPostMap = HM.empty + , _csUsers = noUsers + , _timeZone = tz + , _csEditState = emptyEditState hist sp + , _csMode = Main + , _csShowMessagePreview = configShowMessagePreview $ _crConfiguration rs + , _csChannelSelectString = "" + , _csChannelSelectChannelMatches = mempty + , _csChannelSelectUserMatches = mempty + , _csRecentChannel = Nothing + , _csUrlList = list UrlList mempty 2 + , _csConnectionStatus = Connected + , _csWorkerIsBusy = Nothing + , _csJoinChannelList = Nothing + , _csMessageSelect = MessageSelectState Nothing + , _csPostListOverlay = PostListOverlayState mempty Nothing + } + type ChannelSelectMap = HM.HashMap T.Text ChannelSelectMatch data MessageSelectState = @@ -354,12 +529,6 @@ ((), (st', rs)) <- St.runStateT mote (st, Brick.continue) rs st' --- | Run an 'MM computation, ignoring any requests to quit -runMH :: ChatState -> MH () -> EventM Name ChatState -runMH st (MH mote) = do - ((), (st', _)) <- St.runStateT mote (st, Brick.continue) - return st' - -- | lift a computation in 'EventM' into 'MH' mh :: EventM Name a -> MH a mh = MH . St.lift @@ -417,6 +586,8 @@ -- ^ Tell our main loop to refresh the websocket connection | WebsocketDisconnect | WebsocketConnect + | BGIdle -- ^ background worker is idle + | BGBusy (Maybe Int) -- ^ background worker is busy (with n requests) -- ** Application State Lenses @@ -425,6 +596,12 @@ makeLenses ''ChatEditState makeLenses ''PostListOverlayState +resetSpellCheckTimer :: ChatEditState -> IO () +resetSpellCheckTimer s = + case s^.cedSpellChecker of + Nothing -> return () + Just (_, reset) -> reset + -- ** Utility Lenses csCurrentChannelId :: Lens' ChatState ChannelId csCurrentChannelId = csFocus.focusL @@ -438,10 +615,6 @@ csChannel cId = csChannels . channelByIdL cId -csChannel' :: ChannelId -> Lens' ChatState (Maybe ClientChannel) -csChannel' cId = - csChannels . maybeChannelByIdL cId - withChannel :: ChannelId -> (ClientChannel -> MH ()) -> MH () withChannel cId = withChannelOrDefault cId () @@ -452,39 +625,11 @@ Nothing -> return deflt Just c -> mote c -csUser :: UserId -> Lens' ChatState UserInfo -csUser uId = - lens (\ st -> findUserById uId (st^.csUsers) ^?! _Just) - (\ st n -> st & csUsers %~ addUser uId n) - --- ** Interim lenses for backwards compat - -csSession :: Lens' ChatState Session -csSession = csResources . crSession - -csCmdLine :: Lens' ChatState (Editor T.Text Name) -csCmdLine = csEditState . cedEditor - -csInputHistory :: Lens' ChatState InputHistory -csInputHistory = csEditState . cedInputHistory - -csInputHistoryPosition :: Lens' ChatState (HM.HashMap ChannelId (Maybe Int)) -csInputHistoryPosition = csEditState . cedInputHistoryPosition - -csLastChannelInput :: Lens' ChatState (HM.HashMap ChannelId (T.Text, EditMode)) -csLastChannelInput = csEditState . cedLastChannelInput - -csCurrentCompletion :: Lens' ChatState (Maybe T.Text) -csCurrentCompletion = csEditState . cedCurrentCompletion - -timeFormat :: SimpleGetter ChatState (Maybe T.Text) -timeFormat = csResources . crConfiguration . to configTimeFormat - -dateFormat :: SimpleGetter ChatState (Maybe T.Text) -dateFormat = csResources . crConfiguration . to configDateFormat - -- ** 'ChatState' Helper Functions +isMine :: ChatState -> Message -> Bool +isMine st msg = (Just $ st^.csMe.userUsernameL) == msg^.mUserName + getMessageForPostId :: ChatState -> PostId -> Maybe Message getMessageForPostId st pId = st^.csPostMap.at(pId) @@ -493,22 +638,22 @@ clientPostToMessage :: ChatState -> ClientPost -> Message clientPostToMessage st cp = Message - { _mText = _cpText cp - , _mUserName = case _cpUserOverride cp of + { _mText = cp^.cpText + , _mUserName = case cp^.cpUserOverride of Just n - | _cpType cp == NormalPost -> Just (n <> "[BOT]") - _ -> getUsernameForUserId st =<< _cpUser cp - , _mDate = _cpDate cp - , _mType = CP $ _cpType cp - , _mPending = _cpPending cp - , _mDeleted = _cpDeleted cp - , _mAttachments = _cpAttachments cp + | cp^.cpType == NormalPost -> Just (n <> "[BOT]") + _ -> getUsernameForUserId st =<< cp^.cpUser + , _mDate = cp^.cpDate + , _mType = CP $ cp^.cpType + , _mPending = cp^.cpPending + , _mDeleted = cp^.cpDeleted + , _mAttachments = cp^.cpAttachments , _mInReplyToMsg = case cp^.cpInReplyToPost of Nothing -> NotAReply Just pId -> InReplyTo pId , _mPostId = Just $ cp^.cpPostId - , _mReactions = _cpReactions cp + , _mReactions = cp^.cpReactions , _mOriginalPost = Just $ cp^.cpOriginalPost , _mFlagged = False , _mChannelId = Just $ cp^.cpChannelId @@ -561,27 +706,6 @@ chan <- findChannelById cId (st^.csChannels) lastViewTime <- chan^.ccInfo.cdViewed return (chan^.ccInfo.cdUpdated > lastViewTime) - -sortedUserList :: ChatState -> [UserInfo] -sortedUserList st = sortBy cmp yes <> sortBy cmp no - where - cmp = compareUserInfo uiName - dmHasUnread u = - case st^.csNames.cnToChanId.at(u^.uiName) of - Nothing -> False - Just cId - | (st^.csCurrentChannelId) == cId -> False - | otherwise -> hasUnread st cId - (yes, no) = partition dmHasUnread (userList st) - -compareUserInfo :: (Ord a) => Lens' UserInfo a -> UserInfo -> UserInfo -> Ordering -compareUserInfo field u1 u2 - | u1^.uiStatus == Offline && u2^.uiStatus /= Offline = - GT - | u1^.uiStatus /= Offline && u2^.uiStatus == Offline = - LT - | otherwise = - (u1^.field) `compare` (u2^.field) userList :: ChatState -> [UserInfo] userList st = filter showUser $ allUsers (st^.csUsers) diff --git a/src/Types/Messages.hs b/src/Types/Messages.hs --- a/src/Types/Messages.hs +++ b/src/Types/Messages.hs @@ -97,10 +97,10 @@ -- | Convert a 'ClientMessage' to a 'Message' clientMessageToMessage :: ClientMessage -> Message clientMessageToMessage cm = Message - { _mText = getBlocks (_cmText cm) + { _mText = getBlocks (cm^.cmText) , _mUserName = Nothing - , _mDate = _cmDate cm - , _mType = C $ _cmType cm + , _mDate = cm^.cmDate + , _mType = C $ cm^.cmType , _mPending = False , _mDeleted = False , _mAttachments = Seq.empty diff --git a/src/Types/Posts.hs b/src/Types/Posts.hs --- a/src/Types/Posts.hs +++ b/src/Types/Posts.hs @@ -1,15 +1,57 @@ {-# LANGUAGE MultiWayIf #-} {-# LANGUAGE TemplateHaskell #-} +module Types.Posts + ( ClientMessage + , newClientMessage + , cmDate + , cmType + , cmText -module Types.Posts where + , ClientMessageType(..) + , Attachment + , mkAttachment + , attachmentName + , attachmentFileId + , attachmentURL + + , ClientPostType(..) + + , ClientPost + , toClientPost + , cpUserOverride + , cpUser + , cpText + , cpType + , cpReactions + , cpPending + , cpOriginalPost + , cpInReplyToPost + , cpDate + , cpChannelId + , cpAttachments + , cpDeleted + , cpPostId + + , unEmote + + , postIsLeave + , postIsJoin + , postIsTopicChange + , postIsEmote + + , getBlocks + ) +where + import Cheapskate (Blocks) import qualified Cheapskate as C +import Control.Monad.IO.Class (MonadIO, liftIO) import qualified Data.Map.Strict as Map import Data.Monoid ((<>)) import qualified Data.Sequence as Seq import qualified Data.Text as T -import Data.Time.Clock (UTCTime) +import Data.Time.Clock (UTCTime, getCurrentTime) import Lens.Micro.Platform ((^.), makeLenses) import Network.Mattermost import Network.Mattermost.Lenses @@ -24,6 +66,12 @@ , _cmType :: ClientMessageType } deriving (Eq, Show) +-- | Create a new 'ClientMessage' value +newClientMessage :: (MonadIO m) => ClientMessageType -> T.Text -> m ClientMessage +newClientMessage ty msg = do + now <- liftIO getCurrentTime + return (ClientMessage msg now ty) + -- | We format 'ClientMessage' values differently depending on -- their 'ClientMessageType' data ClientMessageType = @@ -65,6 +113,9 @@ , _attachmentURL :: T.Text , _attachmentFileId :: FileId } deriving (Eq, Show) + +mkAttachment :: T.Text -> T.Text -> FileId -> Attachment +mkAttachment = Attachment -- | A Mattermost 'Post' value can represent either a normal -- chat message or one of several special events. diff --git a/src/Zipper.hs b/src/Zipper.hs --- a/src/Zipper.hs +++ b/src/Zipper.hs @@ -1,4 +1,18 @@ -module Zipper where +module Zipper + ( Zipper + , fromList + , focus + , focusL + , left + , leftL + , right + , rightL + , findLeft + , findRight + , updateList + , filterZipper + ) +where import Prelude () import Prelude.Compat diff --git a/test/Message_QCA.hs b/test/Message_QCA.hs --- a/test/Message_QCA.hs +++ b/test/Message_QCA.hs @@ -99,7 +99,7 @@ ] genAttachment :: Gen Attachment -genAttachment = Attachment +genAttachment = mkAttachment <$> genText <*> genText <*> genFileId