matterhorn 40901.0.0 → 50200.0.0
raw patch · 29 files changed
+341/−116 lines, 29 filesdep ~base-compatdep ~brickdep ~mattermost-api
Dependency ranges changed: base-compat, brick, mattermost-api, mattermost-api-qc, vty
Files
- CHANGELOG.md +44/−0
- PRACTICES.md +11/−5
- README.md +21/−8
- matterhorn.cabal +10/−10
- notification-scripts/notify +32/−13
- src/App.hs +10/−3
- src/Command.hs +4/−1
- src/Config.hs +3/−0
- src/Connection.hs +12/−6
- src/Draw/Main.hs +29/−8
- src/Draw/ShowHelp.hs +1/−0
- src/Draw/Util.hs +7/−6
- src/Draw/ViewMessage.hs +5/−2
- src/Events.hs +4/−4
- src/Events/Keybindings.hs +2/−0
- src/Events/Main.hs +11/−4
- src/Markdown.hs +10/−4
- src/State/ChannelSelect.hs +18/−8
- src/State/Channels.hs +36/−4
- src/State/Common.hs +1/−1
- src/State/Editing.hs +0/−1
- src/State/Messages.hs +3/−3
- src/State/Setup.hs +3/−6
- src/State/Setup/Threads.hs +6/−1
- src/TeamSelect.hs +4/−1
- src/Types.hs +37/−12
- src/Types/KeyEvents.hs +6/−0
- src/Types/Messages.hs +1/−1
- src/Zipper.hs +10/−4
CHANGELOG.md view
@@ -1,4 +1,48 @@ +50200.0.0+=========++This release is compatible with server version 5.2.++New features:++ * The channel list sidebar can now be shown and hidden:+ * With the `/toggle-channel-list` command+ * With the default binding of `F2`+ * With the customized keybinding name of+ `toggle-channel-list-visibility`+ * The account preference for teammate name display is now honored and+ precedence over the server default; at present, only the "nickname"+ and "username" settings are supported.+ * Channel selection mode now matches case-insensitively if the input is+ entirely lowercase and matches case-sensitively otherwise.+ * Non-public channels now include their privacy level in the channel+ header.+ * A bundled "talky" script is now provided for working with the Talky+ video chat service: https://talky.io/ (Thanks @tommd)+ * Theme styles now support italics in terminals that support it. See+ the Theme help info for details.+ * A new key event, "focus-next-unread-user-or-channel", was added.+ This event changes to the next channel with unread messages,+ preferring direct message channels. This event has no default+ binding. (Thanks Brent Carmer)++Bug fixes:+ * Multiline mode in the built-in message editor is now preserved upon+ returning from editing with an external editor (#419)+ * Mixed formatting in hyperlink labels is now supported (#418)+ * When dealing with posts internally, we now use the post's root ID,+ not its parent ID, everywhere since parent IDs are unused (#404)+ * Private channels are no longer included in the tab-completion+ alternative list+ * Theme customization files can now use empty style lists.+ * Message selection mode now disallows selection of deleted messages.+ * The disconnection message is now displayed in a layer to avoid layout+ reflowing in the channel header.+ * Message view mode now properly displays reply parent (#397)+ * The startup team listing is now sorted by team name.+ * We now log websocket timeout and generic exceptions (#385)+ 40901.0.0 =========
PRACTICES.md view
@@ -13,6 +13,11 @@ * We want to manage inevitable software evolution, and * We want to reduce waste through good team coordination. +General+-------++Branches should be `-Wall` clean prior to merging.+ Aesthetics ---------- @@ -54,15 +59,16 @@ shouldn't be used). * Modules with more than a few exports should have an explicit export- list to help us identify dead code.+ list to help us identify dead code and capture API usage+ expectations. - Branching --------- * The `master` branch should be stable enough to be release-ready at- all times. This promise helps us be agile in the event of a need to- do an unplanned release.+ all times. This promise helps us be agile in the event of a need+ to do an unplanned release and it ensures that users who clone the+ repository will get a working build by default. * The `develop` branch is where development occurs. @@ -151,7 +157,7 @@ enough about what's involved in a task to know its level of effort. So in the mean time, before we can investigate, the ticket lingers. -Once we're learning what is inovlved, using the ticket as a place to+Once we're learning what is involved, using the ticket as a place to hash out ideas or collect context is annoying because using ticket comments for that isn't effective.
README.md view
@@ -187,15 +187,18 @@ # Building -`matterhorn` is built with the provided `install.sh` script, which-requires `git` and an appropriate `ghc`/`cabal` installation.-(Although the name suggests installtion, this will just do a build in-`dist-newstyle`.) This script will pull the appropriate repos and build-the application. This is required for building Matterhorn since clones-of some of our other dependencies may need to be locally available in-`deps/` in case important changes to those dependencies have not yet-been released.+To build Matterhorn, you'll need an appropriate `ghc`/`cabal`+installation. We currently build on GHC 8.4. We suggest you use a binary+release if possible. +`matterhorn` is built by running the following commands:++```+$ git pull+$ git submodule update --init+$ ./build.sh+```+ # Our Versioning Scheme Matterhorn version strings will be of the form `ABBCC.X.Y` where ABBCC@@ -229,3 +232,13 @@ * A: No. But we would be happy to work with contributors who are interested in investigating what this would take and/or implementing it. See the Contributing section for details.++* Q: I enabled italicized text in my theme configuration. Why doesn't it+ work?+* A: Most terminfo files for typical terminal configurations do not+ provide support for italicized text. If your terminal emulator+ supports italics, you must enable it in your terminfo database in+ order to use it in Matterhorn. For more information, see these links:+ * http://www.nerdyweekly.com/posts/enable-italic-text-vim-tmux-gnome-terminal/+ * https://medium.com/@dubistkomisch/how-to-actually-get-italics-and-true-colour-to-work-in-iterm-tmux-vim-9ebe55ebc2be+ * https://github.com/tmux/tmux/blob/2.1/FAQ#L355-L383
matterhorn.cabal view
@@ -1,5 +1,5 @@ name: matterhorn-version: 40901.0.0+version: 50200.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@@ -115,8 +115,8 @@ NoImplicitPrelude ghc-options: -Wall -threaded -with-rtsopts=-I0 build-depends: base >=4.8 && <5- , mattermost-api == 40900.1.0- , base-compat >= 0.9 && < 0.10+ , mattermost-api == 50200.0.0+ , base-compat >= 0.9 && < 0.11 , unordered-containers >= 0.2 && < 0.3 , containers >= 0.5.7 && < 0.6 , semigroups >= 0.18 && < 0.19@@ -127,9 +127,9 @@ , config-ini >= 0.2.2.0 && < 0.3 , process >= 1.4 && < 1.7 , microlens-platform >= 0.3 && < 0.4- , brick >= 0.36 && < 0.37+ , brick >= 0.39 && < 0.40 , brick-skylighting >= 0.2 && < 0.3- , vty >= 5.20 && < 5.21+ , vty >= 5.23.1 && < 5.24 , word-wrap >= 0.4.0 && < 0.5 , transformers >= 0.4 && < 0.6 , text-zipper >= 0.10 && < 0.11@@ -175,8 +175,8 @@ ghc-options: -Wall -fno-warn-orphans hs-source-dirs: src, test build-depends: base >=4.7 && <5- , base-compat >= 0.9 && < 0.10- , brick >= 0.36 && < 0.37+ , base-compat >= 0.9 && < 0.11+ , brick >= 0.39 && < 0.40 , bytestring >= 0.10 && < 0.11 , cheapskate >= 0.1 && < 0.2 , checkers >= 0.4 && < 0.5@@ -187,8 +187,8 @@ , filepath >= 1.4 && < 1.5 , hashable >= 1.2 && < 1.3 , Hclip >= 3.0 && < 3.1- , mattermost-api == 40900.1.0- , mattermost-api-qc == 40900.1.0+ , mattermost-api == 50200.0.0+ , mattermost-api-qc == 50200.0.0 , microlens-platform >= 0.3 && < 0.4 , mtl >= 2.2 && < 2.3 , process >= 1.4 && < 1.7@@ -208,7 +208,7 @@ , Unique >= 0.4 && < 0.5 , unordered-containers >= 0.2 && < 0.3 , vector <= 0.12.0.1- , vty >= 5.20 && < 5.21+ , vty >= 5.23.1 && < 5.24 , xdg-basedir >= 0.2 && < 0.3 , semigroups >= 0.18 && < 0.19 , uuid >= 1.3 && < 1.4
notification-scripts/notify view
@@ -1,9 +1,9 @@ #!/bin/sh-#############################################################-# Sample shell-script for using notify-send with matterhorn #-############################################################# -# Positional parameters+# Sample shell script for using notify-send with matterhorn This script+# works on Linux only. It depends on the 'notify-send' command.++# Positional parameters passed to this script by Matterhorn: mentioned="${1?}" sender="${2?}" message="${3?}"@@ -11,28 +11,47 @@ # Script options # notify_URGENCIES-# First word is urgency for items where you are not mentioned, the second is-# urgency for items where you are mentioned. Use "none" to not be notified,-# otherwise low, normal, critical are options+#+# The first word is the urgency for items where you are not mentioned.+# The second word is the urgency for items where you are mentioned.+# Use "none" to not be notified; otherwise use "low", "normal", or+# "critical". notify_URGENCIES="normal normal"-#notify_URGENCIES="none normal"+ # The desktop notification category notify_CATEGORY="im.received"+ # Notification header notify_HEAD="Matterhorn message from $sender"+ # Notification body notify_BODY="$message" getUrgencyHelper() {- shift "$mentioned"- echo "$1"+ if [ "$mentioned" == "1" ]+ then+ echo "$1"+ else+ if [ "$mentioned" == "2" ]+ then+ echo "$2"+ else+ echo "Error: mentioned value '$mentioned' unexpected" > /dev/stderr+ exit 1+ fi+ fi } getUrgency() {- # we are using arguments as a poor-mans bash array for portability+ # We are using arguments as a poor man's bash array for portability # shellcheck disable=SC2086 getUrgencyHelper $notify_URGENCIES } -test "$(getUrgency)" = "none" ||- notify-send -u "$(getUrgency)" -c "$notify_CATEGORY" "$notify_HEAD" "$notify_BODY"+urgency=$(getUrgency)++if [ ! -z "$urgency" ]+then+ test "$urgency" = "none" ||+ notify-send -u "$urgency" -c "$notify_CATEGORY" "$notify_HEAD" "$notify_BODY"+fi
src/App.hs view
@@ -57,10 +57,17 @@ -- | Cleanup resources and save data for restoring on program restart. closeMatterhorn :: ChatState -> IO () closeMatterhorn finalSt = do- logIfError (mmCloseSession $ getResourceSession $ finalSt^.csResources) "Error in closing session"- logIfError (writeHistory (finalSt^.csEditState.cedInputHistory)) "Error in writing history"- logIfError (writeLastRunState finalSt) "Error in writing last run state"+ logIfError (mmCloseSession $ getResourceSession $ finalSt^.csResources)+ "Error in closing session"++ logIfError (writeHistory (finalSt^.csEditState.cedInputHistory))+ "Error in writing history"++ logIfError (writeLastRunState finalSt)+ "Error in writing last run state"+ shutdownLogManager $ finalSt^.csResources.crLogManager+ where logIfError action msg = do done <- runExceptT $ convertIOException $ action
src/Command.hs view
@@ -141,6 +141,9 @@ , Cmd "message-preview" "Toggle preview of the current message" NoArg $ \_ -> toggleMessagePreview + , Cmd "toggle-channel-list" "Toggle channel list visibility" NoArg $ \_ ->+ toggleChannelListVisibility+ , Cmd "focus" "Focus on a channel or user" (TokenArg "channel" NoArg) $ \ (name, ()) -> changeChannel name@@ -194,7 +197,7 @@ , MM.minComCommand = "/" <> name <> " " <> rest , MM.minComParentId = case em of Replying _ p -> Just $ MM.getId p- Editing p _ -> MM.postParentId p+ Editing p _ -> MM.postRootId p _ -> Nothing , MM.minComRootId = case em of Replying _ p -> MM.postRootId p <|> (Just $ MM.postId p)
src/Config.hs view
@@ -87,6 +87,8 @@ (configShowBackground defaultConfig) configShowMessagePreview <- fieldFlagDef "showMessagePreview" (configShowMessagePreview defaultConfig)+ configShowChannelList <- fieldFlagDef "showChannelList"+ (configShowChannelList defaultConfig) configShowTypingIndicator <- fieldFlagDef "showTypingIndicator" (configShowTypingIndicator defaultConfig) configEnableAspell <- fieldFlagDef "enableAspell"@@ -165,6 +167,7 @@ , configActivityBell = False , configShowBackground = Disabled , configShowMessagePreview = False+ , configShowChannelList = True , configEnableAspell = False , configAspellDictionary = Nothing , configUnsafeUseHTTP = False
src/Connection.hs view
@@ -10,6 +10,7 @@ import qualified Data.HashMap.Strict as HM import Data.Int (Int64) import Data.Semigroup ( Max(..) )+import qualified Data.Text as T import Data.Time ( UTCTime(..), secondsToDiffTime, getCurrentTime , diffUTCTime ) import Data.Time.Calendar ( Day(..) )@@ -25,14 +26,15 @@ connectWebsockets = do st <- use id session <- getSession+ logger <- mhGetIOLogger liftIO $ do let shunt (Left msg) = writeBChan (st^.csResources.crEventQueue) (WebsocketParseError msg) shunt (Right e) = writeBChan (st^.csResources.crEventQueue) (WSEvent e) runWS = WS.mmWithWebSocket session shunt $ \ws -> do writeBChan (st^.csResources.crEventQueue) WebsocketConnect processWebsocketActions st ws 1 HM.empty- void $ forkIO $ runWS `catch` handleTimeout 1 st- `catch` handleError 5 st+ void $ forkIO $ runWS `catch` handleTimeout logger 1 st+ `catch` handleError logger 5 st -- | Take websocket actions from the websocket action channel in the ChatState and -- | send them to the server over the websocket.@@ -63,11 +65,15 @@ userTypingLastNotifTimeMap' (UserTyping _ cId _) now = HM.insertWith (<>) cId (Max now) userTypingLastNotifTimeMap -handleTimeout :: Int -> ChatState -> WS.MMWebSocketTimeoutException -> IO ()-handleTimeout seconds st _ = reconnectAfter seconds st+handleTimeout :: (LogCategory -> Text -> IO ()) -> Int -> ChatState -> WS.MMWebSocketTimeoutException -> IO ()+handleTimeout logger seconds st e = do+ logger LogWebsocket $ T.pack $ "Websocket timeout exception: " <> show e+ reconnectAfter seconds st -handleError :: Int -> ChatState -> SomeException -> IO ()-handleError seconds st _ = reconnectAfter seconds st+handleError :: (LogCategory -> Text -> IO ()) -> Int -> ChatState -> SomeException -> IO ()+handleError logger seconds st e = do+ logger LogWebsocket $ T.pack $ "Websocket error: " <> show e+ reconnectAfter seconds st reconnectAfter :: Int -> ChatState -> IO () reconnectAfter seconds st = do
src/Draw/Main.hs view
@@ -24,7 +24,7 @@ import qualified Graphics.Vty as Vty import Lens.Micro.Platform ( (.~), (^?!), to, view, folding ) -import Network.Mattermost.Types ( ChannelId, Type(Direct)+import Network.Mattermost.Types ( ChannelId, Type(Direct, Private, Group) , ServerTime(..), UserId ) @@ -304,7 +304,12 @@ case foundUser of Nothing -> mkChannelName (chan^.ccInfo) Just u -> userHeader u- _ -> mkChannelName (chan^.ccInfo)+ Private ->+ mkChannelName (chan^.ccInfo) <> " (Private)"+ Group ->+ mkChannelName (chan^.ccInfo) <> " (Private group)"+ _ ->+ mkChannelName (chan^.ccInfo) newlineToSpace '\n' = ' ' newlineToSpace c = c @@ -313,11 +318,8 @@ (T.map newlineToSpace (channelNameString <> maybeTopic)) renderCurrentChannelDisplay :: ChatState -> HighlightSet -> Widget Name-renderCurrentChannelDisplay st hs = (header <+> conn) <=> messages+renderCurrentChannelDisplay st hs = header <=> messages where- conn = case st^.csConnectionStatus of- Connected -> emptyWidget- Disconnected -> withDefAttr errorMessageAttr (str "[NOT CONNECTED]") header = withDefAttr channelHeaderAttr $ padRight Max $ renderChannelHeader st hs chan@@ -434,8 +436,25 @@ else cstr)) drawMain :: ChatState -> [Widget Name]-drawMain st = [joinBorders $ mainInterface st]+drawMain st =+ [ connectionLayer st+ , joinBorders $ mainInterface st+ ] +connectionLayer :: ChatState -> Widget Name+connectionLayer st =+ case st^.csConnectionStatus of+ Connected -> emptyWidget+ Disconnected ->+ Widget Fixed Fixed $ do+ ctx <- getContext+ let aw = ctx^.availWidthL+ w = length msg + 2+ msg = "NOT CONNECTED"+ render $ translateBy (Location (max 0 (aw - w), 0)) $+ withDefAttr errorMessageAttr $+ border $ str msg+ messageSelectBottomBar :: ChatState -> Widget Name messageSelectBottomBar st = let optionStr = if null usableOptions@@ -588,7 +607,9 @@ mainInterface :: ChatState -> Widget Name mainInterface st =- vBox [ hBox [hLimit channelListWidth (renderChannelList st), vBorder, mainDisplay]+ vBox [ if st^.csShowChannelList || appMode st == ChannelSelect+ then hBox [hLimit channelListWidth (renderChannelList st), vBorder, mainDisplay]+ else mainDisplay , bottomBorder , inputPreview st hs , userInputArea st hs
src/Draw/ShowHelp.hs view
@@ -301,6 +301,7 @@ "Available styles are:\n" <> " * standout\n" <> " * underline\n" <>+ " * italic\n" <> " * reverseVideo\n" <> " * blink\n" <> " * dim\n" <>
src/Draw/Util.hs view
@@ -68,12 +68,13 @@ mkChannelName :: ChannelInfo -> Text mkChannelName c = T.append sigil (c^.cdName)- where sigil = case c^.cdType of- Private -> T.singleton '?'- Ordinary -> normalChannelSigil- Group -> normalChannelSigil- Direct -> userSigil- _ -> T.singleton '!'+ where+ sigil = case c^.cdType of+ Private -> mempty+ Ordinary -> normalChannelSigil+ Group -> mempty+ Direct -> userSigil+ Unknown _ -> mempty mkDMChannelName :: UserInfo -> Text mkDMChannelName u = T.cons (userSigilFromInfo u) (u^.uiName)
src/Draw/ViewMessage.hs view
@@ -27,13 +27,16 @@ Nothing -> str "BUG: no message to show, please report!" Just msg -> let hs = getHighlightSet st+ parent = case msg^.mInReplyToMsg of+ NotAReply -> Nothing+ InReplyTo pId -> getMessageForPostId st pId in cached ViewMessageArea $ renderMessage $ MessageData { mdEditThreshold = Nothing , mdShowOlderEdits = False , mdMessage = msg , mdUserName = msg^.mUser.to (nameForUserRef st)- , mdParentMessage = Nothing- , mdParentUserName = Nothing+ , mdParentMessage = parent+ , mdParentUserName = parent >>= (^.mUser.to (nameForUserRef st)) , mdRenderReplyParent = True , mdHighlightSet = hs , mdIndentBlocks = True
src/Events.hs view
@@ -135,9 +135,7 @@ -- need to invalidate its cache entry anyway in case the new size -- differs from the cached size. case e of- (Vty.EvResize _ _) -> do- mh $ invalidateCacheEntry HelpText- mh $ invalidateCacheEntry ScriptHelpText+ (Vty.EvResize _ _) -> mh invalidateCache _ -> return () mode <- gets appMode@@ -281,7 +279,9 @@ WMHello -> return () WMAuthenticationChallenge -> return () WMUserRoleUpdated -> return ()-+ WMPluginStatusesChanged -> return ()+ WMPluginEnabled -> return ()+ WMPluginDisabled -> return () -- | Given a configuration, we want to check it for internal -- consistency (i.e. that a given keybinding isn't associated with
src/Events/Keybindings.hs view
@@ -102,11 +102,13 @@ NextChannelEvent -> [ ctrl (key 'n') ] PrevChannelEvent -> [ ctrl (key 'p') ] NextUnreadChannelEvent -> [ meta (key 'a') ]+ NextUnreadUserOrChannelEvent -> [ ] LastChannelEvent -> [ meta (key 's') ] EnterOpenURLModeEvent -> [ ctrl (key 'o') ] ClearUnreadEvent -> [ meta (key 'l') ] ToggleMultiLineEvent -> [ meta (key 'e') ] EnterFlaggedPostsEvent -> [ meta (key '8') ]+ ToggleChannelListVisibleEvent -> [ fn 2 ] CancelEvent -> [ kb Vty.KEsc , ctrl (key 'c')
src/Events/Main.hs view
@@ -57,6 +57,9 @@ , mkKb ToggleMessagePreviewEvent "Toggle message preview" toggleMessagePreview + , mkKb ToggleChannelListVisibleEvent "Toggle channel list visibility"+ toggleChannelListVisibility+ , mkKb InvokeEditorEvent "Invoke *$EDITOR* to edit the current message"@@ -119,6 +122,9 @@ , mkKb NextUnreadChannelEvent "Change to the next channel with unread messages" nextUnreadChannel + , mkKb NextUnreadUserOrChannelEvent "Change to the next channel with unread messages preferring direct messages"+ nextUnreadUserOrChannel+ , mkKb LastChannelEvent "Change to the most recently-focused channel" recentChannel @@ -190,10 +196,11 @@ -- Only permit completion of channel names for non-Group channels ch <- channelByName cname st case ch^.ccInfo.cdType of- Group -> Nothing- _ -> Just [ CompletionAlternative cname (normalChannelSigil <> cname) cname- , mkAlt $ normalChannelSigil <> cname- ]+ Group -> Nothing+ Private -> Nothing+ _ -> Just [ CompletionAlternative cname (normalChannelSigil <> cname) cname+ , mkAlt $ normalChannelSigil <> cname+ ] ) userCompletions = concat $ catMaybes (flip map allUIds $ \uId ->
src/Markdown.hs view
@@ -344,7 +344,7 @@ data Fragment = Fragment { fTextual :: TextFragment , _fStyle :: FragmentStyle- } deriving (Show)+ } deriving (Show, Eq) data TextFragment = TStr Text@@ -355,6 +355,7 @@ | TRawHtml Text | TEditSentinel | TEditRecentlySentinel+ | TComplex (Seq Fragment) deriving (Show, Eq) data FragmentStyle@@ -389,7 +390,7 @@ C.Link label url _ :< xs -> case toList label of [C.Str s] | s == url -> Fragment (TLink url) (Link url) <| go n xs- _ -> go (Link url) label <> go n xs+ _ -> Fragment (TComplex $ toFragments label) (Link url) <| go n xs C.RawHtml t :< xs -> Fragment (TRawHtml t) n <| go n xs C.Code t :< xs ->@@ -496,6 +497,7 @@ TSpace -> 1 TLineBreak -> 0 TSoftBreak -> 0+ TComplex fs -> sum $ fragmentSize <$> fs strOf :: TextFragment -> Text strOf f = case f of@@ -505,6 +507,7 @@ TEditSentinel -> editMarking TEditRecentlySentinel -> editMarking TSpace -> " "+ TComplex fs -> T.concat $ F.toList $ (strOf . fTextual) <$> fs _ -> "" -- This finds adjacent string-ey fragments and concats them, so@@ -523,8 +526,11 @@ Strong -> B.withDefAttr clientStrongAttr rawText Code -> B.withDefAttr codeAttr rawText Link l ->- B.modifyDefAttr (`V.withURL` l)- (B.withDefAttr urlAttr rawText)+ B.hyperlink l $ B.withDefAttr urlAttr $ case frag of+ TComplex fs ->+ hBox $ gatherWidgets fs+ _ ->+ rawText Emoji -> B.withDefAttr emojiAttr rawText User u -> colorUsername u t Channel -> B.withDefAttr channelNameAttr rawText
src/State/ChannelSelect.hs view
@@ -10,6 +10,7 @@ import Prelude () import Prelude.MH +import Data.Char ( isUpper ) import Data.List ( findIndex ) import qualified Data.Text as T import Lens.Micro.Platform@@ -92,30 +93,39 @@ applySelectPattern :: ChannelSelectPattern -> Text -> Maybe ChannelSelectMatch applySelectPattern (CSP ty pat) chanName = do- let applyType Infix | pat `T.isInfixOf` chanName =- case T.breakOn pat chanName of- (pre, post) -> return (pre, pat, T.drop (T.length pat) post)+ let applyType Infix | pat `T.isInfixOf` normalizedChanName =+ case T.breakOn pat normalizedChanName of+ (pre, _) ->+ return ( T.take (T.length pre) chanName+ , T.take (T.length pat) $ T.drop (T.length pre) chanName+ , T.drop (T.length pat + T.length pre) chanName+ ) - applyType Prefix | pat `T.isPrefixOf` chanName = do+ applyType Prefix | pat `T.isPrefixOf` normalizedChanName = do let (b, a) = T.splitAt (T.length pat) chanName return ("", b, a) - applyType UsersOnly | pat `T.isPrefixOf` chanName = do+ applyType UsersOnly | pat `T.isPrefixOf` normalizedChanName = do let (b, a) = T.splitAt (T.length pat) chanName return ("", b, a) - applyType ChannelsOnly | pat `T.isPrefixOf` chanName = do+ applyType ChannelsOnly | pat `T.isPrefixOf` normalizedChanName = do let (b, a) = T.splitAt (T.length pat) chanName return ("", b, a) - applyType Suffix | pat `T.isSuffixOf` chanName = do+ applyType Suffix | pat `T.isSuffixOf` normalizedChanName = do let (b, a) = T.splitAt (T.length chanName - T.length pat) chanName return (b, a, "") - applyType Equal | pat == chanName =+ applyType Equal | pat == normalizedChanName = return ("", chanName, "") applyType _ = Nothing++ caseSensitive = T.any isUpper pat+ normalizedChanName = if caseSensitive+ then chanName+ else T.toLower chanName (pre, m, post) <- applyType ty return $ ChannelSelectMatch pre m post chanName
src/State/Channels.hs view
@@ -13,7 +13,9 @@ , leaveChannelIfPossible , leaveCurrentChannel , getNextUnreadChannel+ , getNextUnreadUserOrChannel , nextUnreadChannel+ , nextUnreadUserOrChannel , prevChannel , nextChannel , recentChannel@@ -37,13 +39,14 @@ , changeChannel , setChannelTopic , beginCurrentChannelDeleteConfirm+ , toggleChannelListVisibility ) where import Prelude () import Prelude.MH -import Brick.Main ( viewportScroll, vScrollToBeginning )+import Brick.Main ( viewportScroll, vScrollToBeginning, invalidateCache ) import Brick.Widgets.Edit ( applyEdit, getEditContents, editContentsL ) import Brick.Widgets.List ( list ) import Control.Concurrent.Async ( runConcurrently, Concurrently(..) )@@ -100,6 +103,11 @@ -- this state is irrelevant. return () +toggleChannelListVisibility :: MH ()+toggleChannelListVisibility = do+ mh invalidateCache+ csShowChannelList %= not+ -- | Called on async completion when the currently viewed channel has -- been updated (i.e., just switched to this channel) to update local -- state.@@ -507,6 +515,11 @@ st <- use id setFocusWith (getNextUnreadChannel st) +nextUnreadUserOrChannel :: MH ()+nextUnreadUserOrChannel = do+ st <- use id+ setFocusWith (getNextUnreadUserOrChannel st)+ leaveChannel :: ChannelId -> MH () leaveChannel cId = leaveChannelIfPossible cId False @@ -570,18 +583,37 @@ -- for the next candidate channel. Z.findRight (\cId -> hasUnread st cId && (cId /= st^.csCurrentChannelId)) +getNextUnreadUserOrChannel :: ChatState+ -> Zipper ChannelId+ -> Zipper ChannelId+getNextUnreadUserOrChannel st z =+ -- Find the next unread channel, prefering direct messages+ let isDM c = getChannelType st c == Direct+ isFresh c = hasUnread st c && (c /= st^.csCurrentChannelId)+ in fromMaybe (Z.findRight isFresh z) (Z.maybeFindRight (\cId -> isDM cId && isFresh cId) z)++-- | Select the next channel in the channel zipper that is not a DM+-- channel.+--+-- If the currently selected channel is a DM channel, do nothing because+-- we want to prevent zipper navigation away from direct channels+-- because we don't support navigating *back* to such channels using the+-- same navigation bindings. getNextNonDMChannel :: ChatState -> (Zipper ChannelId -> Zipper ChannelId) -> (Zipper ChannelId -> Zipper ChannelId) getNextNonDMChannel st shift z =- if fType z == Direct+ if getChannelType st (Z.focus z) == Direct then z else go (shift z) where go z' | fType z' /= Direct = z' | otherwise = go (shift z')- fType onz = st^.(csChannels.to- (findChannelById (Z.focus onz))) ^?! _Just.ccInfo.cdType+ fType onz = getChannelType st (Z.focus onz)++getChannelType :: ChatState -> ChannelId -> Type+getChannelType st cId =+ st^.(csChannels.to (findChannelById cId)) ^?! _Just.ccInfo.cdType leaveCurrentChannel :: MH () leaveCurrentChannel = use csCurrentChannelId >>= leaveChannel
src/State/Common.hs view
@@ -75,7 +75,7 @@ clientPost :: Post -> ClientPost clientPost x = toClientPost x (postId <$> parent x) parent x = do- parentId <- x^.postParentIdL+ parentId <- x^.postRootIdL HM.lookup parentId (p^.postsPostsL) findPost pId = case HM.lookup pId (postsPosts p) of Nothing -> error $ "BUG: could not find post for post ID " <> show pId
src/State/Editing.hs view
@@ -81,7 +81,6 @@ Right t -> do let tmpLines = T.lines $ sanitizeUserText' t return $ st & csEditState.cedEditor.editContentsL .~ (Z.textZipper tmpLines Nothing)- & csEditState.cedMultiline .~ (length tmpLines > 1) Sys.ExitFailure _ -> return st toggleMessagePreview :: MH ()
src/State/Messages.hs view
@@ -119,7 +119,7 @@ editMessage new = do myId <- gets myUserId let isEditedMessage m = m^.mMessageId == Just (MessagePostId $ new^.postIdL)- msg = clientPostToMessage (toClientPost new (new^.postParentIdL))+ msg = clientPostToMessage (toClientPost new (new^.postRootIdL)) chan = csChannel (new^.postChannelIdL) chan . ccContents . cdMessages . traversed . filtered isEditedMessage .= msg @@ -312,7 +312,7 @@ return NoAction Just _ -> do- let cp = toClientPost new (new^.postParentIdL)+ let cp = toClientPost new (new^.postRootIdL) fromMe = (cp^.cpUser == (Just $ myUserId st)) && (isNothing $ cp^.cpUserOverride) userPrefs = st^.csResources.crUserPreferences@@ -359,7 +359,7 @@ (\_ p -> do let postMap = HM.fromList [ ( pId , clientPostToMessage- (toClientPost x (x^.postParentIdL))+ (toClientPost x (x^.postRootIdL)) ) | (pId, x) <- HM.toList (p^.postsPostsL) ]
src/State/Setup.hs view
@@ -135,16 +135,13 @@ Just t -> return t userStatusLock <- newMVar ()- userIdSet <- STM.atomically $ STM.newTVar mempty- slc <- STM.newTChanIO wac <- STM.newTChanIO prefs <- mmGetUsersPreferences UserMe session let userPrefs = setUserPreferences prefs defaultUserPreferences-- let themeName = case configTheme config of+ themeName = case configTheme config of Nothing -> internalThemeName defaultTheme Just t -> t baseTheme = internalTheme $ fromMaybe defaultTheme (lookupTheme themeName)@@ -219,8 +216,8 @@ cChannel <- makeClientChannel c return (getId c, cChannel) - tz <- lookupLocalTimeZone- hist <- do+ tz <- lookupLocalTimeZone+ hist <- do result <- readHistory case result of Left _ -> return newHistory
src/State/Setup/Threads.hs view
@@ -302,4 +302,9 @@ -- E.g. -- https://github.com/matterhorn-chat/matterhorn/issues/391 shouldIgnore :: SomeException -> Bool-shouldIgnore e = "getAddrInfo" `isInfixOf` show e+shouldIgnore e =+ let eStr = show e+ in or [ "getAddrInfo" `isInfixOf` eStr+ , "Network.Socket.recvBuf: timeout" `isInfixOf` eStr+ , "resource vanished" `isInfixOf` eStr+ ]
src/TeamSelect.hs view
@@ -10,6 +10,8 @@ import Brick.Widgets.Border import Brick.Widgets.Center import Brick.Widgets.List+import qualified Data.Function as F+import Data.List ( sortBy ) import qualified Data.Vector as V import Graphics.Vty import System.Exit ( exitSuccess )@@ -24,7 +26,8 @@ interactiveTeamSelection :: [Team] -> IO Team interactiveTeamSelection teams = do- let state = list () (V.fromList teams) 1+ let state = list () (V.fromList sortedTeams) 1+ sortedTeams = sortBy (compare `F.on` teamName) teams finalSt <- defaultMain app state let Just (_, t) = listSelectedElement finalSt return t
src/Types.hs view
@@ -56,6 +56,7 @@ , csCurrentChannelId , csUrlList , csShowMessagePreview+ , csShowChannelList , csPostMap , csRecentChannel , csPostListOverlay@@ -129,6 +130,7 @@ , userPrefShowJoinLeave , userPrefFlaggedPostList , userPrefGroupChannelPrefs+ , userPrefTeammateNameDisplayMode , defaultUserPreferences , setUserPreferences@@ -150,6 +152,7 @@ , mhError , mhLog+ , mhGetIOLogger , LogContext(..) , withLogContext , withLogContextChannelId@@ -315,6 +318,8 @@ -- ^ Whether to show async background worker thread info. , configShowMessagePreview :: Bool -- ^ Whether to show the message preview area.+ , configShowChannelList :: Bool+ -- ^ Whether to show the channel list. , configEnableAspell :: Bool -- ^ Whether to enable Aspell spell checking. , configAspellDictionary :: Maybe Text@@ -519,6 +524,7 @@ UserPreferences { _userPrefShowJoinLeave :: Bool , _userPrefFlaggedPostList :: Seq FlaggedPost , _userPrefGroupChannelPrefs :: HashMap ChannelId Bool+ , _userPrefTeammateNameDisplayMode :: Maybe TeammateNameDisplayMode } defaultUserPreferences :: UserPreferences@@ -526,6 +532,7 @@ UserPreferences { _userPrefShowJoinLeave = True , _userPrefFlaggedPostList = mempty , _userPrefGroupChannelPrefs = mempty+ , _userPrefTeammateNameDisplayMode = Nothing } setUserPreferences :: Seq Preference -> UserPreferences -> UserPreferences@@ -545,12 +552,17 @@ | preferenceName p == PreferenceName "join_leave" = u { _userPrefShowJoinLeave = preferenceValue p /= PreferenceValue "false" }+ | preferenceCategory p == PreferenceCategoryDisplaySettings &&+ preferenceName p == PreferenceName "name_format" =+ let PreferenceValue txt = preferenceValue p+ in u { _userPrefTeammateNameDisplayMode = Just $ teammateDisplayModeFromText txt } | otherwise = u -- | Log message tags. data LogCategory = LogGeneral | LogAPI+ | LogWebsocket | LogError deriving (Eq, Show) @@ -761,6 +773,8 @@ -- routines. , _csShowMessagePreview :: Bool -- ^ Whether to show the message preview area.+ , _csShowChannelList :: Bool+ -- ^ Whether to show the channe list. , _csChannelSelectState :: ChannelSelectState -- ^ The state of the user's input and selection for -- channel selection mode.@@ -821,6 +835,7 @@ , _csEditState = emptyEditState startupStateInitialHistory startupStateSpellChecker , _csMode = Main , _csShowMessagePreview = configShowMessagePreview $ _crConfiguration startupStateResources+ , _csShowChannelList = configShowChannelList $ _crConfiguration startupStateResources , _csChannelSelectState = emptyChannelSelectState , _csRecentChannel = Nothing , _csUrlList = list UrlList mempty 2@@ -943,15 +958,23 @@ -- | Log a message. mhLog :: LogCategory -> Text -> MH () mhLog cat msg = do+ logger <- mhGetIOLogger+ liftIO $ logger cat msg++-- | Get a logger suitable for use in IO. The logger always logs using+-- the MH monad log context at the time of the call to mhGetIOLogger.+mhGetIOLogger :: MH (LogCategory -> Text -> IO ())+mhGetIOLogger = do ctx <- getLogContext- now <- liftIO getCurrentTime- let lm = LogMessage { logMessageText = msg- , logMessageContext = ctx- , logMessageCategory = cat- , logMessageTimestamp = now- } mgr <- use (to (_crLogManager . _csResources))- liftIO $ sendLogMessage mgr lm+ return $ \cat msg -> do+ now <- liftIO getCurrentTime+ let lm = LogMessage { logMessageText = msg+ , logMessageContext = ctx+ , logMessageCategory = cat+ , logMessageTimestamp = now+ }+ liftIO $ sendLogMessage mgr lm -- | Run an 'MM' computation, choosing whether to continue or halt based -- on the resulting@@ -1209,11 +1232,13 @@ in HM.lookup (trimUserSigil uName) nameToChanId useNickname :: ChatState -> Bool-useNickname st = case st^?csClientConfig._Just.to clientConfigTeammateNameDisplay of- Just "nickname_full_name" ->- True- _ ->- False+useNickname st =+ let serverSetting = case st^?csClientConfig._Just.to clientConfigTeammateNameDisplay of+ Just TMNicknameOrFullname -> Just True+ _ -> Nothing+ accountSetting = (== TMNicknameOrFullname) <$> st^.csResources.crUserPreferences.userPrefTeammateNameDisplayMode+ fallback = False+ in fromMaybe fallback $ accountSetting <|> serverSetting channelByName :: Text -> ChatState -> Maybe ClientChannel channelByName n st = do
src/Types/KeyEvents.hs view
@@ -44,11 +44,13 @@ | NextChannelEvent | PrevChannelEvent | NextUnreadChannelEvent+ | NextUnreadUserOrChannelEvent | LastChannelEvent | EnterOpenURLModeEvent | ClearUnreadEvent | ToggleMultiLineEvent | EnterFlaggedPostsEvent+ | ToggleChannelListVisibleEvent -- generic cancel | CancelEvent@@ -102,9 +104,11 @@ , NextChannelEvent , PrevChannelEvent , NextUnreadChannelEvent+ , NextUnreadUserOrChannelEvent , LastChannelEvent , EnterFlaggedPostsEvent+ , ToggleChannelListVisibleEvent , ShowHelpEvent , EnterSelectModeEvent , EnterOpenURLModeEvent@@ -285,9 +289,11 @@ NextChannelEvent -> "focus-next-channel" PrevChannelEvent -> "focus-prev-channel" NextUnreadChannelEvent -> "focus-next-unread"+ NextUnreadUserOrChannelEvent -> "focus-next-unread-user-or-channel" LastChannelEvent -> "focus-last-channel" EnterFlaggedPostsEvent -> "show-flagged-posts"+ ToggleChannelListVisibleEvent -> "toggle-channel-list-visibility" ShowHelpEvent -> "show-help" EnterSelectModeEvent -> "select-mode" EnterOpenURLModeEvent -> "enter-url-open"
src/Types/Messages.hs view
@@ -490,7 +490,7 @@ _ -> False validSelectableMessage :: Message -> Bool-validSelectableMessage m = isJust $ m^.mMessageId+validSelectableMessage m = (not $ m^.mDeleted) && (isJust $ m^.mMessageId) -- ---------------------------------------------------------------------- -- * Operations on any Message type
src/Zipper.hs view
@@ -9,6 +9,7 @@ , rightL , findLeft , findRight+ , maybeFindRight , updateList , filterZipper )@@ -61,12 +62,17 @@ -- Shift the focus until a given element is found, or return the -- same zipper if none applies findRight :: (a -> Bool) -> Zipper a -> Zipper a-findRight f z- | f (focus z) = z+findRight f z = fromMaybe z $ maybeFindRight f z++-- Shift the focus until a given element is found, or return+-- Nothing if none applies+maybeFindRight :: (a -> Bool) -> Zipper a -> Maybe (Zipper a)+maybeFindRight f z+ | f (focus z) = Just z | otherwise = go (right z) (zFocus z) where go zC n- | n == zFocus zC = zC- | f (focus zC) = zC+ | n == zFocus zC = Nothing+ | f (focus zC) = Just zC | otherwise = go (right zC) n -- Shift the focus until a given element is found, or return the