Browse Source

Merge feature/theme-files

Jonathan Daugherty 2 years ago
parent
commit
3952137a28
13 changed files with 390 additions and 133 deletions
  1. 74
    0
      CHANGELOG.md
  2. 3
    0
      README.md
  3. 4
    4
      matterhorn.cabal
  4. 5
    0
      src/Command.hs
  5. 5
    0
      src/Draw/Messages.hs
  6. 10
    2
      src/Draw/PostListOverlay.hs
  7. 7
    6
      src/Events.hs
  8. 15
    3
      src/Markdown.hs
  9. 244
    98
      src/State.hs
  10. 14
    0
      src/State/PostListOverlay.hs
  11. 4
    4
      src/State/Setup.hs
  12. 4
    15
      src/Types.hs
  13. 1
    1
      src/Types/Channels.hs

+ 74
- 0
CHANGELOG.md View File

@@ -1,3 +1,77 @@
1
+40400.0.0
2
+=========
3
+
4
+This release supports server version 4.4.
5
+
6
+New features:
7
+ * Edited posts are now displayed with a trailling "edited"
8
+   marker. This change includes some new behavior and a new
9
+   configuration option:
10
+   * When you visit a post that has recent edits, the "edited" marker
11
+     will be highlighted. This highlight can be dismissed in the same
12
+     way as the "New Messages" cutoff, using the `M-l` keybinding.
13
+   * This feature can be turned off using by setting the
14
+     `showOlderEdits` configuration option to `False`.
15
+ * New commands:
16
+   * The `/remove-user` command removes a user from a channel.
17
+   * The `/group-msg` command creates a new private group channel
18
+     including several users.
19
+   * The `/search [term]` command searches the chat history for posts
20
+     that include the provided text and displays those posts in an
21
+     overlay. Thanks to @abhin4v for this change!
22
+ * Matterhorn now includes embedded hyperlinks using terminal escape
23
+   sequences in terminals that support them. For more information on
24
+   terminal support for hyperlink escape sequences, please see [this
25
+   gist](https://gist.github.com/egmontkob/eb114294efbcd5adb1944c9f3cb5feda)
26
+   and its associated discussion.
27
+ * The width of the channel list (in columns) is now configurable with
28
+   `channelListWidth`, which defaults to 20.
29
+ * The `urlOpenCommand` can now be an interactive terminal-based
30
+   program (such as a terminal-based web browser) but this requires
31
+   the configuration option `urlOpenCommandIsInteractive` to be set to
32
+   `True`. This defaults to `False` and should not be changed if the
33
+   `urlOpenCommand` is not a terminal-based program.
34
+ * The current selection in channel select mode can be moved forward
35
+   and backward with `C-n` and `C-p`. (fixes #139)
36
+ * Quotation blocks now include visible characters in addition to
37
+   indentation.
38
+ * We now honor the server's notification settings for channels.
39
+
40
+Bug fixes:
41
+ * New direct-message channels are properly added to running sessions
42
+   (fixes #264)
43
+ * No more reporting of "resource vanished" exceptions (fixes #116)
44
+ * Missing editing keybindings now included in edit binding list
45
+   (fixes #139)
46
+ * Websocket message parse failures no longer result in crashes (fixes
47
+   #297)
48
+ * The sidebar no longer shows deleted users (fixes #316)
49
+ * Tab-completion no longer includes deleted users (fixes #320)
50
+ * User status updates are now rate-limited (fixes #282)
51
+ * Private channels can be deleted successfully (fixes #304)
52
+ * External commands now run in the background in their own thread and
53
+   do not block the main UI (fixes #270)
54
+ * Channel renaming is honored at runtime and does not require a
55
+   restart (fixes #324)
56
+ * Group channel show/hide preferences are observed, which in practice
57
+   means a user can now 'leave' a several-user group channel
58
+ * New channels will not appear twice in the sidebar (fixes #327)
59
+ * New messages to previously-hidden group channels will cause the
60
+   group channel to be shown again (fixes #326)
61
+
62
+
63
+Package changes:
64
+ * PRACTICES.md is now listed in extra-doc-files.
65
+ * Three scripts usable with the `/sh` command are now listed in
66
+   extra-doc-files:
67
+   * `cowsay` runs the message text through the `cowsay` shell command
68
+     and formats the output as a verbatim block. This command requires
69
+     the `cowsay` command-line program to be installed externally.
70
+   * `figlet` runs the message text through the `figlet` shell command
71
+     and formats the output as a verbatim block. This command requires
72
+     the `figlet` command-line program to be installed externally.
73
+   * `rot13` runs the trivial ROT13 subsitution cipher over the
74
+     message text and otherwise passes it through unchanged.
1 75
 
2 76
 40000.1.0
3 77
 =========

+ 3
- 0
README.md View File

@@ -75,6 +75,9 @@ To join a channel, use the `/join` command to choose from a list of
75 75
 available channels. To create a channel, use `/create-channel`. To leave
76 76
 a channel, use `/leave-channel`.
77 77
 
78
+To create a private group chat amongst yourself and other users, use the
79
+`/group-msg` command, e.g., `/group-msg user1 user2`.
80
+
78 81
 To see the members in the current channel, use the `/members` command.
79 82
 
80 83
 To send a message, type it into the editor and press Enter to send.

+ 4
- 4
matterhorn.cabal View File

@@ -1,5 +1,5 @@
1 1
 name:                matterhorn
2
-version:             40000.1.0
2
+version:             40400.0.0
3 3
 synopsis:            Terminal client for the Mattermost chat system
4 4
 description:         This is a terminal client for the Mattermost chat
5 5
                      system. Please see the README for a list of
@@ -82,7 +82,7 @@ executable matterhorn
82 82
                        ScopedTypeVariables
83 83
   ghc-options:         -Wall -threaded
84 84
   build-depends:       base                 >=4.8     && <5
85
-                     , mattermost-api       == 40000.1.0
85
+                     , mattermost-api       == 40400.0.0
86 86
                      , base-compat          >= 0.9    && < 0.10
87 87
                      , unordered-containers >= 0.2    && < 0.3
88 88
                      , containers           >= 0.5.7  && < 0.6
@@ -141,8 +141,8 @@ test-suite test_messages
141 141
                     , filepath             >= 1.4    && < 1.5
142 142
                     , hashable             >= 1.2    && < 1.3
143 143
                     , Hclip                >= 3.0    && < 3.1
144
-                    , mattermost-api       == 40000.1.0
145
-                    , mattermost-api-qc    == 40000.1.0
144
+                    , mattermost-api       == 40400.0.0
145
+                    , mattermost-api-qc    == 40400.0.0
146 146
                     , microlens-platform   >= 0.3    && < 0.4
147 147
                     , mtl                  >= 2.2    && < 2.3
148 148
                     , process              >= 1.4    && < 1.7

+ 5
- 0
src/Command.hs View File

@@ -88,6 +88,8 @@ commandList =
88 88
               Just topic -> showHelpScreen topic
89 89
   , Cmd "sh" "List the available shell scripts" NoArg $ \ () ->
90 90
       listScripts
91
+  , Cmd "group-msg" "Create a group chat"
92
+    (LineArg "user1 user2 ...") createGroupChannel
91 93
   , Cmd "sh" "Run a prewritten shell script"
92 94
     (TokenArg "script" (LineArg "message")) $ \ (script, text) ->
93 95
       findAndRunScript script text
@@ -101,6 +103,9 @@ commandList =
101 103
 
102 104
   , Cmd "flags" "Open up a pane of flagged posts"  NoArg $ \ () ->
103 105
       enterFlaggedPostListMode
106
+
107
+  , Cmd "search" "Search for posts with given terms"  (LineArg "terms") $
108
+      enterSearchResultPostListMode
104 109
   ]
105 110
 
106 111
 execMMCommand :: T.Text -> T.Text -> MH ()

+ 5
- 0
src/Draw/Messages.hs View File

@@ -24,6 +24,11 @@ import           Types.Messages
24 24
 maxMessageHeight :: Int
25 25
 maxMessageHeight = 200
26 26
 
27
+-- | renderSingleMessage is the main message drawing function.
28
+--
29
+-- The `ind` argument specifies an "indicator boundary".  Showing
30
+-- various indicators (e.g. "edited") is not typically done for
31
+-- messages that are older than this boundary value.
27 32
 renderSingleMessage :: ChatState -> Maybe UTCTime -> UserSet -> ChannelSet -> Message -> Widget Name
28 33
 renderSingleMessage st ind uSet cSet =
29 34
   renderChatMessage st ind uSet cSet (withBrackets . renderTime st)

+ 10
- 2
src/Draw/PostListOverlay.hs View File

@@ -69,7 +69,11 @@ drawPostsBox contents st =
69 69
     padRight (Pad 1) messageListContents
70 70
   where -- The 'window title' of the overlay
71 71
         contentHeader = withAttr channelListHeaderAttr $ txt $ case contents of
72
-          PostListFlagged -> "Flagged posts"
72
+          PostListFlagged                -> "Flagged posts"
73
+          PostListSearch terms searching -> "Search results" <> if searching
74
+            then ": " <> terms
75
+            else " (" <> (T.pack . show . length) (st^.csPostListOverlay.postListPosts) <> "): " <> terms
76
+
73 77
         -- User and channel set, for use in message rendering
74 78
         uSet = Set.fromList (st^..csUsers.to allUsers.folded.uiName)
75 79
         cSet = Set.fromList (st^..csChannels.folded.ccInfo.cdName)
@@ -87,7 +91,11 @@ drawPostsBox contents st =
87 91
             hCenter $
88 92
             withDefAttr clientEmphAttr $
89 93
             str $ case contents of
90
-              PostListFlagged -> "You have no flagged messages."
94
+              PostListFlagged            -> "You have no flagged messages."
95
+              PostListSearch _ searching ->
96
+                if searching
97
+                  then "Searching ..."
98
+                  else "No search results found"
91 99
           | otherwise = vBox renderedMessageList
92 100
 
93 101
         -- The render-message function we're using

+ 7
- 6
src/Events.hs View File

@@ -159,12 +159,9 @@ handleWSEvent we = do
159 159
             | Just p <- wepPost $ weData we -> postInfoMessage $ p^.postMessageL
160 160
             | otherwise -> return ()
161 161
 
162
-        -- The only preference we observe right now is flagging
163 162
         WMPreferenceChanged
164
-            | Just pref <- wepPreferences (weData we)
165
-            , Just fps <- mapM preferenceToFlaggedPost pref ->
166
-              forM_ fps $ \f ->
167
-                  updateMessageFlag (flaggedPostId f) (flaggedPostStatus f)
163
+            | Just prefs <- wepPreferences (weData we) ->
164
+                mapM_ applyPreferenceChange prefs
168 165
             | otherwise -> return ()
169 166
 
170 167
         WMPreferenceDeleted
@@ -192,6 +189,10 @@ handleWSEvent we = do
192 189
             | Just cId <- webChannelId $ weBroadcast we -> refreshChannelById False cId
193 190
             | otherwise -> return ()
194 191
 
192
+        WMGroupAdded
193
+            | Just cId <- webChannelId (weBroadcast we) -> handleChannelInvite cId
194
+            | otherwise -> return ()
195
+
195 196
         -- We are pretty sure we should do something about these:
196 197
         WMAddedToTeam -> return ()
197 198
 
@@ -203,9 +204,9 @@ handleWSEvent we = do
203 204
 
204 205
         -- We deliberately ignore these events:
205 206
         WMChannelCreated -> return ()
206
-        WMGroupAdded -> return ()
207 207
         WMEmojiAdded -> return ()
208 208
         WMWebRTC -> return ()
209 209
         WMTyping -> return ()
210 210
         WMHello -> return ()
211 211
         WMAuthenticationChallenge -> return ()
212
+        WMUserRoleUpdated -> return ()

+ 15
- 3
src/Markdown.hs View File

@@ -99,8 +99,20 @@ appendEditSentinel sentinel b =
99 99
         C.Para is -> S.singleton $ C.Para (is |> C.Str " " |> m)
100 100
         _ -> S.fromList [b, s]
101 101
 
102
+-- | renderMessage performs markdown rendering of the specified message.
103
+--
104
+-- The 'mEditThreshold' argument specifies a time boundary where
105
+-- "edited" markers are not shown for any messages older than this
106
+-- mark (under the presumption that they are distracting for really
107
+-- old stuff).  The mEditThreshold will be None if there is no
108
+-- boundary known yet; the boundary is typically set to the "new"
109
+-- message boundary.
110
+--
111
+-- The 'showOlderEdits' argument is a value read from the user's
112
+-- configuration file that indicates that "edited" markers should be
113
+-- shown for old messages (i.e., ignore the mEditThreshold value).
102 114
 renderMessage :: ChatState -> Maybe UTCTime -> Bool -> Message -> Bool -> UserSet -> ChannelSet -> Bool -> Widget a
103
-renderMessage st mEditTheshold showOlderEdits msg renderReplyParent uSet cSet indentBlocks =
115
+renderMessage st mEditThreshold showOlderEdits msg renderReplyParent uSet cSet indentBlocks =
104 116
     let msgUsr = case msg^.mUserName of
105 117
           Just u
106 118
             | msg^.mType `elem` omitUsernameTypes -> Nothing
@@ -128,7 +140,7 @@ renderMessage st mEditTheshold showOlderEdits msg renderReplyParent uSet cSet in
128 140
             Nothing -> bs
129 141
             Just p ->
130 142
                 if p^.postUpdateAtL > p^.postCreateAtL
131
-                then case mEditTheshold of
143
+                then case mEditThreshold of
132 144
                     Just cutoff | p^.postUpdateAtL >= cutoff ->
133 145
                         addEditSentinel editRecentlyMarkingSentinel bs
134 146
                     _ -> if showOlderEdits
@@ -149,7 +161,7 @@ renderMessage st mEditTheshold showOlderEdits msg renderReplyParent uSet cSet in
149 161
               case getMessageForPostId st parentId of
150 162
                   Nothing -> withParent (B.str "[loading...]")
151 163
                   Just pm ->
152
-                      let parentMsg = renderMessage st mEditTheshold False pm False uSet cSet False
164
+                      let parentMsg = renderMessage st mEditThreshold False pm False uSet cSet False
153 165
                       in withParent (addEllipsis $ B.forceAttr replyParentAttr parentMsg)
154 166
 
155 167
     where

+ 244
- 98
src/State.hs View File

@@ -41,6 +41,7 @@ module State
41 41
   , handleChannelInvite
42 42
   , addUserToCurrentChannel
43 43
   , removeUserFromCurrentChannel
44
+  , createGroupChannel
44 45
 
45 46
   -- * Channel history
46 47
   , channelHistoryForward
@@ -68,6 +69,9 @@ module State
68 69
   , channelSelectNext
69 70
   , channelSelectPrevious
70 71
 
72
+  -- * Server-side preferences
73
+  , applyPreferenceChange
74
+
71 75
   -- * Message selection mode
72 76
   , beginMessageSelect
73 77
   , flagSelectedMessage
@@ -140,7 +144,8 @@ import           System.Environment.XDG.BaseDir (getUserCacheDir)
140 144
 import           System.FilePath
141 145
 
142 146
 import           Network.Mattermost
143
-import           Network.Mattermost.Types (NotifyOption(..))
147
+import           Network.Mattermost.Types (NotifyOption(..), GroupChannelPreference(..),
148
+                                           preferenceToGroupChannelPreference)
144 149
 import           Network.Mattermost.Lenses
145 150
 
146 151
 import           Config
@@ -170,17 +175,24 @@ refreshChannel refreshMessages cwd@(ChannelWithData chan _) = do
170 175
   let cId = getId chan
171 176
   curId <- use csCurrentChannelId
172 177
 
173
-  -- If this channel is unknown, register it first.
174
-  mChan <- preuse (csChannel(cId))
175
-  when (isNothing mChan) $
176
-      handleNewChannel False cwd
177
-
178
-  updateChannelInfo cId cwd
179
-
180
-  -- If this is an active channel or the current channel, also update
181
-  -- the Messages to retrieve any that might have been missed.
182
-  when (refreshMessages || (cId == curId)) $
183
-      updateMessages cId
178
+  -- If this is a group channel that the user has chosen to hide, ignore
179
+  -- the refresh request.
180
+  isHidden <- channelHiddenPreference cId
181
+  case isHidden of
182
+      True -> return ()
183
+      False -> do
184
+          -- If this channel is unknown, register it first.
185
+          mChan <- preuse (csChannel(cId))
186
+          when (isNothing mChan) $
187
+              handleNewChannel False cwd
188
+
189
+          updateChannelInfo cId cwd
190
+
191
+          -- If this is an active channel or the current channel, also
192
+          -- update the Messages to retrieve any that might have been
193
+          -- missed.
194
+          when (refreshMessages || (cId == curId)) $
195
+              updateMessages cId
184 196
 
185 197
 refreshChannelById :: Bool -> ChannelId -> MH ()
186 198
 refreshChannelById refreshMessages cId = do
@@ -190,6 +202,76 @@ refreshChannelById refreshMessages cId = do
190 202
       cwd <- mmGetChannel session myTeamId cId
191 203
       return $ refreshChannel refreshMessages cwd
192 204
 
205
+createGroupChannel :: T.Text -> MH ()
206
+createGroupChannel usernameList = do
207
+    users <- use csUsers
208
+    myTeamId <- use (csMyTeam.teamIdL)
209
+    me <- use csMe
210
+
211
+    let usernames = T.words usernameList
212
+        findUserIds [] = return []
213
+        findUserIds (n:ns) = do
214
+            case findUserByName users n of
215
+                Nothing -> do
216
+                    postErrorMessage $ "No such user: " <> n
217
+                    return []
218
+                Just (uId, _) -> (uId:) <$> findUserIds ns
219
+
220
+    results <- findUserIds usernames
221
+
222
+    -- If we found all of the users mentioned, then create the group
223
+    -- channel.
224
+    when (length results == length usernames) $ do
225
+        session <- use (csResources.crSession)
226
+        doAsyncWith Preempt $ do
227
+            chan <- mmCreateGroupChannel session results
228
+            let pref = showGroupChannelPref (channelId chan) (me^.userIdL)
229
+            -- It's possible that the channel already existed, in which
230
+            -- case we want to request a preference change to show it.
231
+            mmSetPreferences session (me^.userIdL) $ Seq.fromList [pref]
232
+            cwd <- mmGetChannel session myTeamId (channelId chan)
233
+            return $ do
234
+                applyPreferenceChange pref
235
+                handleNewChannel True cwd
236
+
237
+channelHiddenPreference :: ChannelId -> MH Bool
238
+channelHiddenPreference cId = do
239
+  prefs <- use (csResources.crPreferences)
240
+  let matching = filter (\p -> groupChannelId p == cId) $
241
+                 catMaybes $ preferenceToGroupChannelPreference <$> (F.toList prefs)
242
+  return $ any (not . groupChannelShow) matching
243
+
244
+applyPreferenceChange :: Preference -> MH ()
245
+applyPreferenceChange pref
246
+    | Just f <- preferenceToFlaggedPost pref =
247
+        updateMessageFlag (flaggedPostId f) (flaggedPostStatus f)
248
+    | Just g <- preferenceToGroupChannelPreference pref = do
249
+        -- First, go update the preferences with this change.
250
+        updatePreference pref
251
+
252
+        let cId = groupChannelId g
253
+        mChan <- preuse $ csChannel cId
254
+
255
+        case (mChan, groupChannelShow g) of
256
+            (Just _, False) ->
257
+                -- If it has been set to hidden and we are showing it,
258
+                -- remove it from the state.
259
+                removeChannelFromState cId
260
+            (Nothing, True) ->
261
+                -- If it has been set to showing and we are not showing
262
+                -- it, ask for a load/refresh.
263
+                refreshChannelById True cId
264
+            _ -> return ()
265
+applyPreferenceChange _ = return ()
266
+
267
+updatePreference :: Preference -> MH ()
268
+updatePreference pref = do
269
+    let replacePreference new old
270
+            | preferenceCategory old == preferenceCategory new &&
271
+              preferenceName old == preferenceName new = new
272
+            | otherwise = old
273
+    csResources.crPreferences %= fmap (replacePreference pref)
274
+
193 275
 -- | Refresh information about all channels and users. This is usually
194 276
 -- triggered when a reconnect event for the WebSocket to the server
195 277
 -- occurs.
@@ -214,12 +296,41 @@ refreshChannelsAndUsers = do
214 296
         lock <- use (csResources.crUserStatusLock)
215 297
         doAsyncWith Preempt $ updateUserStatuses lock session
216 298
 
299
+-- | Update the indicted Channel entry with the new data retrieved from
300
+-- the Mattermost server. Also update the channel name if it changed.
217 301
 updateChannelInfo :: ChannelId -> ChannelWithData -> MH ()
218
-updateChannelInfo cid cwd =
302
+updateChannelInfo cid cwd@(ChannelWithData new _) = do
303
+  mOldChannel <- preuse $ csChannel(cid)
304
+  case mOldChannel of
305
+      Nothing -> return ()
306
+      Just old ->
307
+          let oldName = old^.ccInfo.cdName
308
+              newName = preferredChannelName new
309
+          in if oldName == newName
310
+             then return ()
311
+             else do
312
+                 removeChannelName oldName
313
+                 addChannelName (channelType new) cid newName
314
+
219 315
   csChannel(cid).ccInfo %= channelInfoFromChannelWithData cwd
220 316
 
317
+addChannelName :: Type -> ChannelId -> T.Text -> MH ()
318
+addChannelName chType cid name = do
319
+    csNames.cnToChanId.at(name) .= Just cid
320
+
321
+    -- For direct channels the username is already in the user list so
322
+    -- do nothing
323
+    existingNames <- use $ csNames.cnChans
324
+    when (chType /= Direct && (not $ name `elem` existingNames)) $
325
+        csNames.cnChans %= (sort . (name:))
326
+
327
+removeChannelName :: T.Text -> MH ()
328
+removeChannelName name = do
329
+    -- Flush cnToChanId
330
+    csNames.cnToChanId.at name .= Nothing
331
+    -- Flush cnChans
332
+    csNames.cnChans %= filter (/= name)
333
+
221 334
 -- | If this channel has content, fetch any new content that has
222 335
 -- arrived after the existing content.
223 336
 updateMessages :: ChannelId -> MH ()
@@ -614,6 +725,10 @@ leaveChannelIfPossible cId delete = do
614 725
                                 Private -> case all isMe members of
615 726
                                     True -> mmDeleteChannel
616 727
                                     False -> mmLeaveChannel
728
+                                Group ->
729
+                                    \s _ _ ->
730
+                                        mmSetPreferences s (me^.userIdL) $
731
+                                            Seq.fromList [hideGroupChannelPref cId $ me^.userIdL]
617 732
                                 _ -> if delete
618 733
                                      then mmDeleteChannel
619 734
                                      else mmLeaveChannel
@@ -621,6 +736,22 @@ leaveChannelIfPossible cId delete = do
621 736
                         doAsyncChannelMM Preempt cId func endAsyncNOP
622 737
                     )
623 738
 
739
+hideGroupChannelPref :: ChannelId -> UserId -> Preference
740
+hideGroupChannelPref cId uId =
741
+    Preference { preferenceCategory = PreferenceCategoryGroupChannelShow
742
+               , preferenceValue = PreferenceValue "false"
743
+               , preferenceName = PreferenceName $ idString cId
744
+               , preferenceUserId = uId
745
+               }
746
+
747
+showGroupChannelPref :: ChannelId -> UserId -> Preference
748
+showGroupChannelPref cId uId =
749
+    Preference { preferenceCategory = PreferenceCategoryGroupChannelShow
750
+               , preferenceValue = PreferenceValue "true"
751
+               , preferenceName = PreferenceName $ idString cId
752
+               , preferenceUserId = uId
753
+               }
754
+
624 755
 leaveChannel :: ChannelId -> MH ()
625 756
 leaveChannel cId = leaveChannelIfPossible cId False
626 757
 
@@ -638,10 +769,8 @@ removeChannelFromState cId = do
638 769
             csEditState.cedLastChannelInput     .at cId .= Nothing
639 770
             -- Update input history
640 771
             csEditState.cedInputHistory         %= removeChannelHistory cId
641
-            -- Flush cnToChanId
642
-            csNames.cnToChanId                  .at cName .= Nothing
643
-            -- Flush cnChans
644
-            csNames.cnChans                     %= filter (/= cName)
772
+            -- Remove channel name mappings
773
+            removeChannelName cName
645 774
             -- Update msgMap
646 775
             csChannels                          %= filteredChannels ((/=) cId . fst)
647 776
             -- Remove from focus zipper
@@ -1004,81 +1133,85 @@ handleNewChannel_ :: Bool
1004 1133
                   -- ^ The channel to install.
1005 1134
                   -> MH ()
1006 1135
 handleNewChannel_ permitPostpone switch cwd@(ChannelWithData nc cData) = do
1007
-  -- Create a new ClientChannel structure
1008
-  let cChannel = makeClientChannel nc &
1009
-                   ccInfo %~ channelInfoFromChannelWithData (ChannelWithData nc cData)
1010
-
1011
-  st <- use id
1012
-
1013
-  -- Add it to the message map, and to the name map so we can look it up
1014
-  -- by name. The name we use for the channel depends on its type:
1015
-  let chType = nc^.channelTypeL
1016
-
1017
-  -- Get the channel name. If we couldn't, that means we have async work
1018
-  -- to do before we can register this channel (in which case abort
1019
-  -- because we got rescheduled).
1020
-  mName <- case chType of
1021
-      Direct -> case userIdForDMChannel (st^.csMe.userIdL) $ channelName nc of
1022
-          -- If this is a direct channel but we can't extract a user ID
1023
-          -- from the name, then it failed to parse. We need to assign
1024
-          -- a channel name in our channel map, and the best we can do
1025
-          -- to preserve uniqueness is to use the channel name string.
1026
-          -- This is undesirable but direct channels never get rendered
1027
-          -- directly; they only get used by first looking up usernames.
1028
-          -- So this name should never appear anywhere, but at least we
1029
-          -- can go ahead and register the channel and handle events for
1030
-          -- it. That isn't very useful but it's probably better than
1031
-          -- ignoring this entirely.
1032
-          Nothing -> return $ Just $ channelName nc
1033
-          Just otherUserId ->
1034
-              case getUsernameForUserId st otherUserId of
1035
-                  -- If we found a user ID in the channel name string
1036
-                  -- but don't have that user's metadata, postpone
1037
-                  -- adding this channel until we have fetched the
1038
-                  -- metadata. This can happen when we have a channel
1039
-                  -- record for a user that is no longer in the current
1040
-                  -- team. To avoid recursion due to a problem, ensure
1041
-                  -- that the rescheduled new channel handler is not
1042
-                  -- permitted to try this again.
1043
-                  --
1044
-                  -- If we're already in a recursive attempt to register
1045
-                  -- this channel and still couldn't find a username,
1046
-                  -- just bail and use the synthetic name (this has the
1047
-                  -- same problems as above).
1048
-                  Nothing -> do
1049
-                      case permitPostpone of
1050
-                          False -> return $ Just $ channelName nc
1051
-                          True -> do
1052
-                              handleNewUser otherUserId
1053
-                              doAsyncWith Normal $
1054
-                                  return $ handleNewChannel_ False switch cwd
1055
-                              return Nothing
1056
-                  Just ncUsername ->
1057
-                      return $ Just $ ncUsername
1058
-      _ -> return $ Just $ preferredChannelName nc
1059
-
1060
-  case mName of
1061
-      Nothing -> return ()
1062
-      Just name -> do
1063
-          csNames.cnToChanId.at(name) .= Just (getId nc)
1064
-
1065
-          -- For direct channels the username is already in the user
1066
-          -- list so do nothing
1067
-          when (chType /= Direct) $
1068
-              csNames.cnChans %= (sort . (name:))
1136
+  -- Only add the channel to the state if it isn't already known.
1137
+  mChan <- preuse (csChannel(getId nc))
1138
+  case mChan of
1139
+      Just _ -> return ()
1140
+      Nothing -> do
1141
+        -- Create a new ClientChannel structure
1142
+        let cChannel = makeClientChannel nc &
1143
+                         ccInfo %~ channelInfoFromChannelWithData (ChannelWithData nc cData)
1144
+
1145
+        st <- use id
1146
+
1147
+        -- Add it to the message map, and to the name map so we can look
1148
+        -- it up by name. The name we use for the channel depends on its
1149
+        -- type:
1150
+        let chType = nc^.channelTypeL
1151
+
1152
+        -- Get the channel name. If we couldn't, that means we have
1153
+        -- async work to do before we can register this channel (in
1154
+        -- which case abort because we got rescheduled).
1155
+        mName <- case chType of
1156
+            Direct -> case userIdForDMChannel (st^.csMe.userIdL) $ channelName nc of
1157
+                -- If this is a direct channel but we can't extract a
1158
+                -- user ID from the name, then it failed to parse. We
1159
+                -- need to assign a channel name in our channel map,
1160
+                -- and the best we can do to preserve uniqueness is to
1161
+                -- use the channel name string. This is undesirable
1162
+                -- but direct channels never get rendered directly;
1163
+                -- they only get used by first looking up usernames.
1164
+                -- So this name should never appear anywhere, but at
1165
+                -- least we can go ahead and register the channel and
1166
+                -- handle events for it. That isn't very useful but it's
1167
+                -- probably better than ignoring this entirely.
1168
+                Nothing -> return $ Just $ channelName nc
1169
+                Just otherUserId ->
1170
+                    case getUsernameForUserId st otherUserId of
1171
+                        -- If we found a user ID in the channel name
1172
+                        -- string but don't have that user's metadata,
1173
+                        -- postpone adding this channel until we have
1174
+                        -- fetched the metadata. This can happen when
1175
+                        -- we have a channel record for a user that
1176
+                        -- is no longer in the current team. To avoid
1177
+                        -- recursion due to a problem, ensure that
1178
+                        -- the rescheduled new channel handler is not
1179
+                        -- permitted to try this again.
1180
+                        --
1181
+                        -- If we're already in a recursive attempt to
1182
+                        -- register this channel and still couldn't find
1183
+                        -- a username, just bail and use the synthetic
1184
+                        -- name (this has the same problems as above).
1185
+                        Nothing -> do
1186
+                            case permitPostpone of
1187
+                                False -> return $ Just $ channelName nc
1188
+                                True -> do
1189
+                                    handleNewUser otherUserId
1190
+                                    doAsyncWith Normal $
1191
+                                        return $ handleNewChannel_ False switch cwd
1192
+                                    return Nothing
1193
+                        Just ncUsername ->
1194
+                            return $ Just $ ncUsername
1195
+            _ -> return $ Just $ preferredChannelName nc
1196
+
1197
+        case mName of
1198
+            Nothing -> return ()
1199
+            Just name -> do
1200
+                addChannelName chType (getId nc) name
1069 1201
 
1070
-          csChannels %= addChannel (getId nc) cChannel
1202
+                csChannels %= addChannel (getId nc) cChannel
1071 1203
 
1072
-          -- We should figure out how to do this better: this adds it to
1073
-          -- the channel zipper in such a way that we don't ever change
1074
-          -- our focus to something else, which is kind of silly
1075
-          names <- use csNames
1076
-          let newZip = Z.updateList (mkChannelZipperList names)
1077
-          csFocus %= newZip
1204
+                -- We should figure out how to do this better: this adds
1205
+                -- it to the channel zipper in such a way that we don't
1206
+                -- ever change our focus to something else, which is
1207
+                -- kind of silly
1208
+                names <- use csNames
1209
+                let newZip = Z.updateList (mkChannelZipperList names)
1210
+                csFocus %= newZip
1078 1211
 
1079
-          -- Finally, set our focus to the newly created channel if the
1080
-          -- caller requested a change of channel.
1081
-          when switch $ setFocus (getId nc)
1212
+                -- Finally, set our focus to the newly created channel
1213
+                -- if the caller requested a change of channel.
1214
+                when switch $ setFocus (getId nc)
1082 1215
 
1083 1216
 editMessage :: Post -> MH ()
1084 1217
 editMessage new = do
@@ -1181,15 +1314,26 @@ addMessageToState newPostData = do
1181 1314
   st <- use id
1182 1315
   case st ^? csChannel(postChannelId new) of
1183 1316
       Nothing -> do
1184
-          -- When we join channels, sometimes we get the "user has
1185
-          -- been added to channel" message here BEFORE we get the
1186
-          -- websocket event that says we got added to a channel. This
1187
-          -- means the message arriving here in addMessage can't be
1188
-          -- added yet because we haven't fetched the channel metadata
1189
-          -- in the websocket handler. So to be safe we just drop the
1190
-          -- message here, but this is the only case of messages that we
1191
-          -- /expect/ to drop for this reason. Hence the check for the
1192
-          -- msgMap channel ID key presence above.
1317
+          session <- use (csResources.crSession)
1318
+          myTeamId <- use (csMyTeam.teamIdL)
1319
+          doAsyncWith Preempt $ do
1320
+              cwd@(ChannelWithData nc _) <- mmGetChannel session myTeamId (postChannelId new)
1321
+
1322
+              let chType = nc^.channelTypeL
1323
+                  pref = showGroupChannelPref (postChannelId new) (st^.csMe.userIdL)
1324
+
1325
+              return $ do
1326
+                  -- If the incoming message is for a group channel we
1327
+                  -- don't know about, that's because it was previously
1328
+                  -- hidden by the user. We need to show it, and to do
1329
+                  -- that we need to update the server-side preference.
1330
+                  -- (That, in turn, triggers a channel refresh.)
1331
+                  if chType == Group
1332
+                      then applyPreferenceChange pref
1333
+                      else refreshChannel True cwd
1334
+
1335
+                  addMessageToState newPostData >>= postProcessMessageAdd
1336
+
1193 1337
           return NoAction
1194 1338
       Just _ -> do
1195 1339
           let cp = toClientPost new (new^.postParentIdL)

+ 14
- 0
src/State/PostListOverlay.hs View File

@@ -1,5 +1,6 @@
1 1
 module State.PostListOverlay where
2 2
 
3
+import Data.Text (Text)
3 4
 import Lens.Micro.Platform
4 5
 import Network.Mattermost
5 6
 import Network.Mattermost.Lenses
@@ -36,6 +37,19 @@ enterFlaggedPostListMode = do
36 37
       messages <- messagesFromPosts posts
37 38
       enterPostListMode PostListFlagged messages
38 39
 
40
+-- | Create a PostListOverlay with post search result messages from the
41
+-- server.
42
+enterSearchResultPostListMode :: Text -> MH ()
43
+enterSearchResultPostListMode terms = do
44
+  session <- use (csResources.crSession)
45
+  tId <- teamId <$> use csMyTeam
46
+  enterPostListMode (PostListSearch terms True) noMessages
47
+  doAsyncWith Preempt $ do
48
+    posts <- mmSearchPosts session tId terms False
49
+    return $ do
50
+      messages <- messagesFromPosts posts
51
+      enterPostListMode (PostListSearch terms False) messages
52
+
39 53
 -- | Move the selection up in the PostListOverlay, which corresponds
40 54
 -- to finding a chronologically /newer/ message.
41 55
 postListSelectUp :: MH ()

+ 4
- 4
src/State/Setup.hs View File

@@ -124,6 +124,8 @@ setupState logFile config requestChan eventChan = do
124 124
 
125 125
   slc <- STM.atomically STM.newTChan
126 126
 
127
+  prefs <- mmGetMyPreferences session
128
+
127 129
   let themeName = case configTheme config of
128 130
           Nothing -> internalThemeName defaultTheme
129 131
           Just t -> t
@@ -152,14 +154,12 @@ setupState logFile config requestChan eventChan = do
152 154
 
153 155
   let cr = ChatResources session cd requestChan eventChan
154 156
              slc (themeToAttrMap custTheme) quitCondition
155
-             userStatusLock config mempty
157
+             userStatusLock config mempty prefs
156 158
 
157 159
   initializeState cr myTeam myUser
158 160
 
159 161
 initializeState :: ChatResources -> Team -> User -> IO ChatState
160 162
 initializeState cr myTeam myUser = do
161
-  prefs <- mmGetMyPreferences (cr^.crSession)
162
-
163 163
   let session = cr^.crSession
164 164
       requestChan = cr^.crRequestQueue
165 165
       myTeamId = getId myTeam
@@ -204,5 +204,5 @@ initializeState cr myTeam myUser = do
204 204
              & csChannels %~ flip (foldr (uncurry addChannel)) msgs
205 205
              & csNames .~ chanNames
206 206
 
207
-  loadFlaggedMessages prefs st
207
+  loadFlaggedMessages (cr^.crPreferences) st
208 208
   return st

+ 4
- 15
src/Types.hs View File

@@ -93,6 +93,7 @@ module Types
93 93
   , postListPosts
94 94
 
95 95
   , ChatResources(ChatResources)
96
+  , crPreferences
96 97
   , crEventQueue
97 98
   , crTheme
98 99
   , crSession
@@ -128,7 +129,6 @@ module Types
128 129
   , channelNameFromMatch
129 130
   , isMine
130 131
   , getUsernameForUserId
131
-  , getLastChannelPreference
132 132
   , sortedUserList
133 133
 
134 134
   , userSigil
@@ -219,21 +219,6 @@ data Config = Config
219 219
 
220 220
 data BackgroundInfo = Disabled | Active | ActiveCount deriving (Eq, Show)
221 221
 
222
-
223
-getLastChannelPreference :: Seq.Seq Preference -> Maybe ChannelId
224
-getLastChannelPreference prefs =
225
-    let isLastChannelIdPreference p =
226
-            and [ preferenceCategory p == PreferenceCategoryLast
227
-                , preferenceName     p == PreferenceName "channel"
228
-                ]
229
-        prefChannelId p =
230
-            let PreferenceValue v = preferenceValue p
231
-            in CI $ Id v
232
-
233
-    in prefChannelId <$>
234
-       (listToMaybe $ F.toList $ Seq.filter isLastChannelIdPreference prefs)
235
-
236 222
 -- * 'MMNames' structures
237 223
 
238 224
 -- | The 'MMNames' record is for listing human-readable
@@ -385,6 +370,7 @@ data ChatResources = ChatResources
385 370
   , _crUserStatusLock :: MVar ()
386 371
   , _crConfiguration :: Config
387 372
   , _crFlaggedPosts  :: Set PostId
373
+  , _crPreferences   :: Seq.Seq Preference
388 374
   }
389 375
 
390 376
 -- | The 'ChatEditState' value contains the editor widget itself
@@ -453,8 +439,8 @@ data HelpTopic =
453 439
 -- | Mode type for the current contents of the post list overlay
454 440
 data PostListContents
455 441
   = PostListFlagged
442
+  | PostListSearch T.Text Bool -- for the query and search status
443
+  --   | PostListPinned ChannelId
456 444
   deriving (Eq)
457 445
 
458 446
 -- | The 'Mode' represents the current dominant UI activity

+ 1
- 1
src/Types/Channels.hs View File

@@ -261,7 +261,7 @@ makeClientChannel nc = ClientChannel
261 261
   }
262 262
 
263 263
 canLeaveChannel :: ChannelInfo -> Bool
264
-canLeaveChannel cInfo = not $ cInfo^.cdType `elem` [Direct, Group]
264
+canLeaveChannel cInfo = not $ cInfo^.cdType `elem` [Direct]
265 265
 
266 266
 -- ** Manage the collection of all Channels
267 267
 

Loading…
Cancel
Save