diff --git a/CHANGELOG.md b/CHANGELOG.md --- a/CHANGELOG.md +++ b/CHANGELOG.md @@ -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 ========= diff --git a/PRACTICES.md b/PRACTICES.md --- a/PRACTICES.md +++ b/PRACTICES.md @@ -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. diff --git a/README.md b/README.md --- a/README.md +++ b/README.md @@ -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 diff --git a/matterhorn.cabal b/matterhorn.cabal --- a/matterhorn.cabal +++ b/matterhorn.cabal @@ -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 diff --git a/notification-scripts/notify b/notification-scripts/notify --- a/notification-scripts/notify +++ b/notification-scripts/notify @@ -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 diff --git a/src/App.hs b/src/App.hs --- a/src/App.hs +++ b/src/App.hs @@ -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 diff --git a/src/Command.hs b/src/Command.hs --- a/src/Command.hs +++ b/src/Command.hs @@ -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) diff --git a/src/Config.hs b/src/Config.hs --- a/src/Config.hs +++ b/src/Config.hs @@ -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 diff --git a/src/Connection.hs b/src/Connection.hs --- a/src/Connection.hs +++ b/src/Connection.hs @@ -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 diff --git a/src/Draw/Main.hs b/src/Draw/Main.hs --- a/src/Draw/Main.hs +++ b/src/Draw/Main.hs @@ -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 diff --git a/src/Draw/ShowHelp.hs b/src/Draw/ShowHelp.hs --- a/src/Draw/ShowHelp.hs +++ b/src/Draw/ShowHelp.hs @@ -301,6 +301,7 @@ "Available styles are:\n" <> " * standout\n" <> " * underline\n" <> + " * italic\n" <> " * reverseVideo\n" <> " * blink\n" <> " * dim\n" <> diff --git a/src/Draw/Util.hs b/src/Draw/Util.hs --- a/src/Draw/Util.hs +++ b/src/Draw/Util.hs @@ -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) diff --git a/src/Draw/ViewMessage.hs b/src/Draw/ViewMessage.hs --- a/src/Draw/ViewMessage.hs +++ b/src/Draw/ViewMessage.hs @@ -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 diff --git a/src/Events.hs b/src/Events.hs --- a/src/Events.hs +++ b/src/Events.hs @@ -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 diff --git a/src/Events/Keybindings.hs b/src/Events/Keybindings.hs --- a/src/Events/Keybindings.hs +++ b/src/Events/Keybindings.hs @@ -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') diff --git a/src/Events/Main.hs b/src/Events/Main.hs --- a/src/Events/Main.hs +++ b/src/Events/Main.hs @@ -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 -> diff --git a/src/Markdown.hs b/src/Markdown.hs --- a/src/Markdown.hs +++ b/src/Markdown.hs @@ -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 diff --git a/src/State/ChannelSelect.hs b/src/State/ChannelSelect.hs --- a/src/State/ChannelSelect.hs +++ b/src/State/ChannelSelect.hs @@ -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 diff --git a/src/State/Channels.hs b/src/State/Channels.hs --- a/src/State/Channels.hs +++ b/src/State/Channels.hs @@ -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 diff --git a/src/State/Common.hs b/src/State/Common.hs --- a/src/State/Common.hs +++ b/src/State/Common.hs @@ -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 diff --git a/src/State/Editing.hs b/src/State/Editing.hs --- a/src/State/Editing.hs +++ b/src/State/Editing.hs @@ -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 () diff --git a/src/State/Messages.hs b/src/State/Messages.hs --- a/src/State/Messages.hs +++ b/src/State/Messages.hs @@ -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) ] diff --git a/src/State/Setup.hs b/src/State/Setup.hs --- a/src/State/Setup.hs +++ b/src/State/Setup.hs @@ -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 diff --git a/src/State/Setup/Threads.hs b/src/State/Setup/Threads.hs --- a/src/State/Setup/Threads.hs +++ b/src/State/Setup/Threads.hs @@ -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 + ] diff --git a/src/TeamSelect.hs b/src/TeamSelect.hs --- a/src/TeamSelect.hs +++ b/src/TeamSelect.hs @@ -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 diff --git a/src/Types.hs b/src/Types.hs --- a/src/Types.hs +++ b/src/Types.hs @@ -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 diff --git a/src/Types/KeyEvents.hs b/src/Types/KeyEvents.hs --- a/src/Types/KeyEvents.hs +++ b/src/Types/KeyEvents.hs @@ -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" diff --git a/src/Types/Messages.hs b/src/Types/Messages.hs --- a/src/Types/Messages.hs +++ b/src/Types/Messages.hs @@ -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 diff --git a/src/Zipper.hs b/src/Zipper.hs --- a/src/Zipper.hs +++ b/src/Zipper.hs @@ -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