matterhorn 31000.0.0 → 40000.0.0
raw patch · 23 files changed
+847/−602 lines, 23 filesdep ~mattermost-apidep ~mattermost-api-qcdep ~time
Dependency ranges changed: mattermost-api, mattermost-api-qc, time, vector
Files
- README.md +4/−0
- matterhorn.cabal +9/−8
- src/Config.hs +15/−0
- src/Connection.hs +1/−1
- src/Draw/ChannelList.hs +25/−2
- src/Draw/Main.hs +44/−32
- src/Draw/Messages.hs +1/−1
- src/Draw/Util.hs +4/−2
- src/Events.hs +14/−5
- src/Events/Main.hs +12/−12
- src/Main.hs +24/−2
- src/Markdown.hs +12/−7
- src/State.hs +79/−76
- src/State/Common.hs +46/−65
- src/State/Editing.hs +39/−39
- src/State/PostListOverlay.hs +1/−1
- src/State/Setup.hs +33/−258
- src/State/Setup/Threads.hs +204/−0
- src/Types.hs +208/−84
- src/Types/Messages.hs +3/−3
- src/Types/Posts.hs +53/−2
- src/Zipper.hs +15/−1
- test/Message_QCA.hs +1/−1
README.md view
@@ -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
matterhorn.cabal view
@@ -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
src/Config.hs view
@@ -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)
src/Connection.hs view
@@ -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
src/Draw/ChannelList.hs view
@@ -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)
src/Draw/Main.hs view
@@ -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 ""
src/Draw/Messages.hs view
@@ -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
src/Draw/Util.hs view
@@ -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)
src/Events.hs view
@@ -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 ()
src/Events/Main.hs view
@@ -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
src/Main.hs view
@@ -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
src/Markdown.hs view
@@ -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
src/State.hs view
@@ -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
src/State/Common.hs view
@@ -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 ()
src/State/Editing.hs view
@@ -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 ()
src/State/PostListOverlay.hs view
@@ -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
src/State/Setup.hs view
@@ -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
+ src/State/Setup/Threads.hs view
@@ -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
src/Types.hs view
@@ -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)
src/Types/Messages.hs view
@@ -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
src/Types/Posts.hs view
@@ -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.
src/Zipper.hs view
@@ -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
test/Message_QCA.hs view
@@ -99,7 +99,7 @@ ] genAttachment :: Gen Attachment-genAttachment = Attachment+genAttachment = mkAttachment <$> genText <*> genText <*> genFileId