1{-# LANGUAGE TemplateHaskell #-}
2{-# LANGUAGE DeriveFunctor #-}
3{-# LANGUAGE DeriveFoldable #-}
4{-# LANGUAGE DeriveTraversable #-}
5{-# LANGUAGE RankNTypes #-}
6{-# LANGUAGE FlexibleInstances #-}
7
8module Matterhorn.Types.Channels
9  ( ClientChannel(..)
10  , ChannelContents(..)
11  , ChannelInfo(..)
12  , ClientChannels -- constructor remains internal
13  , NewMessageIndicator(..)
14  , EphemeralEditState(..)
15  , EditMode(..)
16  , eesMultiline, eesInputHistoryPosition, eesLastInput
17  , defaultEphemeralEditState
18  -- * Lenses created for accessing ClientChannel fields
19  , ccContents, ccInfo, ccEditState
20  -- * Lenses created for accessing ChannelInfo fields
21  , cdViewed, cdNewMessageIndicator, cdEditedMessageThreshold, cdUpdated
22  , cdName, cdDisplayName, cdHeader, cdPurpose, cdType
23  , cdMentionCount, cdTypingUsers, cdDMUserId, cdChannelId
24  , cdSidebarShowOverride, cdNotifyProps, cdTeamId
25  -- * Lenses created for accessing ChannelContents fields
26  , cdMessages, cdFetchPending
27  -- * Creating ClientChannel objects
28  , makeClientChannel
29  -- * Managing ClientChannel collections
30  , noChannels, addChannel, removeChannel, findChannelById, modifyChannelById
31  , channelByIdL, maybeChannelByIdL
32  , allTeamIds
33  , filteredChannelIds
34  , filteredChannels
35  -- * Creating ChannelInfo objects
36  , channelInfoFromChannelWithData
37  -- * Channel State management
38  , clearNewMessageIndicator
39  , clearEditedThreshold
40  , adjustUpdated
41  , adjustEditedThreshold
42  , updateNewMessageIndicator
43  , addChannelTypingUser
44  -- * Notification settings
45  , notifyPreference
46  , isMuted
47  , channelNotifyPropsMarkUnreadL
48  , channelNotifyPropsIgnoreChannelMentionsL
49  , channelNotifyPropsDesktopL
50  , channelNotifyPropsPushL
51  -- * Miscellaneous channel-related operations
52  , canLeaveChannel
53  , preferredChannelName
54  , isTownSquare
55  , channelDeleted
56  , getDmChannelFor
57  , allDmChannelMappings
58  , getChannelNameSet
59  )
60where
61
62import           Prelude ()
63import           Matterhorn.Prelude
64
65import qualified Data.HashMap.Strict as HM
66import qualified Data.Set as S
67import qualified Data.Text as T
68import           Lens.Micro.Platform ( (%~), (.~), Traversal', Lens'
69                                     , makeLenses, ix, at
70                                     , to, non )
71
72import           Network.Mattermost.Lenses hiding ( Lens' )
73import           Network.Mattermost.Types ( Channel(..), UserId, ChannelId
74                                          , ChannelMember(..)
75                                          , Type(..)
76                                          , Post
77                                          , User(userNotifyProps)
78                                          , ChannelNotifyProps
79                                          , NotifyOption(..)
80                                          , WithDefault(..)
81                                          , ServerTime
82                                          , TeamId
83                                          , emptyChannelNotifyProps
84                                          )
85
86import           Matterhorn.Types.Messages ( Messages, noMessages, addMessage
87                                           , clientMessageToMessage, Message, MessageType )
88import           Matterhorn.Types.Posts ( ClientMessageType(UnknownGapBefore)
89                                        , newClientMessage )
90import           Matterhorn.Types.Users ( TypingUsers, noTypingUsers, addTypingUser )
91import           Matterhorn.Types.Common
92
93
94-- * Channel representations
95
96-- | A 'ClientChannel' contains both the message
97--   listing and the metadata about a channel
98data ClientChannel = ClientChannel
99  { _ccContents :: ChannelContents
100    -- ^ A list of 'Message's in the channel
101  , _ccInfo :: ChannelInfo
102    -- ^ The 'ChannelInfo' for the channel
103  , _ccEditState :: EphemeralEditState
104    -- ^ Editor state that we swap in and out as the current channel is
105    -- changed.
106  }
107
108-- | The input state associated with the message editor.
109data EditMode =
110    NewPost
111    -- ^ The input is for a new post.
112    | Editing Post MessageType
113    -- ^ The input is ultimately to replace the body of an existing post
114    -- of the specified type.
115    | Replying Message Post
116    -- ^ The input is to be used as a new post in reply to the specified
117    -- post.
118    deriving (Show)
119
120data EphemeralEditState =
121    EphemeralEditState { _eesMultiline :: Bool
122                       -- ^ Whether the editor is in multiline mode
123                       , _eesInputHistoryPosition :: Maybe Int
124                       -- ^ The input history position, if any
125                       , _eesLastInput :: (T.Text, EditMode)
126                       -- ^ The input entered into the text editor last
127                       -- time the user was focused on the channel
128                       -- associated with this state.
129                       }
130
131-- Get a channel's name, depending on its type
132preferredChannelName :: Channel -> Text
133preferredChannelName ch
134    | channelType ch == Group = sanitizeUserText $ channelDisplayName ch
135    | otherwise               = sanitizeUserText $ channelName ch
136
137data NewMessageIndicator =
138    Hide
139    | NewPostsAfterServerTime ServerTime
140    | NewPostsStartingAt ServerTime
141    deriving (Eq, Show)
142
143initialChannelInfo :: UserId -> Channel -> ChannelInfo
144initialChannelInfo myId chan =
145    let updated  = chan ^. channelLastPostAtL
146    in ChannelInfo { _cdChannelId              = chan^.channelIdL
147                   , _cdTeamId                 = chan^.channelTeamIdL
148                   , _cdViewed                 = Nothing
149                   , _cdNewMessageIndicator    = Hide
150                   , _cdEditedMessageThreshold = Nothing
151                   , _cdMentionCount           = 0
152                   , _cdUpdated                = updated
153                   , _cdName                   = preferredChannelName chan
154                   , _cdDisplayName            = sanitizeUserText $ channelDisplayName chan
155                   , _cdHeader                 = sanitizeUserText $ chan^.channelHeaderL
156                   , _cdPurpose                = sanitizeUserText $ chan^.channelPurposeL
157                   , _cdType                   = chan^.channelTypeL
158                   , _cdNotifyProps            = emptyChannelNotifyProps
159                   , _cdTypingUsers            = noTypingUsers
160                   , _cdDMUserId               = if chan^.channelTypeL == Direct
161                                                 then userIdForDMChannel myId $
162                                                      sanitizeUserText $ channelName chan
163                                                 else Nothing
164                   , _cdSidebarShowOverride    = Nothing
165                   }
166
167channelInfoFromChannelWithData :: Channel -> ChannelMember -> ChannelInfo -> ChannelInfo
168channelInfoFromChannelWithData chan chanMember ci =
169    let viewed   = chanMember ^. to channelMemberLastViewedAt
170        updated  = chan ^. channelLastPostAtL
171    in ci { _cdViewed           = Just viewed
172          , _cdNewMessageIndicator = case _cdNewMessageIndicator ci of
173              Hide -> if updated > viewed then NewPostsAfterServerTime viewed else Hide
174              v -> v
175          , _cdUpdated          = updated
176          , _cdName             = preferredChannelName chan
177          , _cdDisplayName      = sanitizeUserText $ channelDisplayName chan
178          , _cdHeader           = (sanitizeUserText $ chan^.channelHeaderL)
179          , _cdPurpose          = (sanitizeUserText $ chan^.channelPurposeL)
180          , _cdType             = (chan^.channelTypeL)
181          , _cdMentionCount     = chanMember^.to channelMemberMentionCount
182          , _cdNotifyProps      = chanMember^.to channelMemberNotifyProps
183          }
184
185-- | The 'ChannelContents' is a wrapper for a list of
186--   'Message' values
187data ChannelContents = ChannelContents
188  { _cdMessages :: Messages
189  , _cdFetchPending :: Bool
190  }
191
192-- | An initial empty 'ChannelContents' value.  This also contains an
193-- UnknownGapBefore, which is a signal that causes actual content fetching.
194-- The initial Gap's timestamp is the local client time, but
195-- subsequent fetches will synchronize with the server (and eventually
196-- eliminate this Gap as well).
197emptyChannelContents :: MonadIO m => m ChannelContents
198emptyChannelContents = do
199  gapMsg <- clientMessageToMessage <$> newClientMessage UnknownGapBefore "--Fetching messages--"
200  return $ ChannelContents { _cdMessages = addMessage gapMsg noMessages
201                           , _cdFetchPending = False
202                           }
203
204
205------------------------------------------------------------------------
206
207-- | The 'ChannelInfo' record represents metadata
208--   about a channel
209data ChannelInfo = ChannelInfo
210  { _cdChannelId        :: ChannelId
211    -- ^ The channel's ID
212  , _cdTeamId           :: Maybe TeamId
213    -- ^ The channel's team ID
214  , _cdViewed           :: Maybe ServerTime
215    -- ^ The last time we looked at a channel
216  , _cdNewMessageIndicator :: NewMessageIndicator
217    -- ^ The state of the channel's new message indicator.
218  , _cdEditedMessageThreshold :: Maybe ServerTime
219    -- ^ The channel's edited message threshold.
220  , _cdMentionCount     :: Int
221    -- ^ The current number of unread mentions
222  , _cdUpdated          :: ServerTime
223    -- ^ The last time a message showed up in the channel
224  , _cdName             :: Text
225    -- ^ The name of the channel
226  , _cdDisplayName      :: Text
227    -- ^ The display name of the channel
228  , _cdHeader           :: Text
229    -- ^ The header text of a channel
230  , _cdPurpose          :: Text
231    -- ^ The stated purpose of the channel
232  , _cdType             :: Type
233    -- ^ The type of a channel: public, private, or DM
234  , _cdNotifyProps      :: ChannelNotifyProps
235    -- ^ The user's notification settings for this channel
236  , _cdTypingUsers      :: TypingUsers
237    -- ^ The users who are currently typing in this channel
238  , _cdDMUserId         :: Maybe UserId
239    -- ^ The user associated with this channel, if it is a DM channel
240  , _cdSidebarShowOverride :: Maybe UTCTime
241    -- ^ If set, show this channel in the sidebar regardless of other
242    -- considerations as long as the specified timestamp meets a cutoff.
243    -- Otherwise fall back to other application policy to determine
244    -- whether to show the channel.
245  }
246
247-- ** Channel-related Lenses
248
249makeLenses ''ChannelContents
250makeLenses ''ChannelInfo
251makeLenses ''ClientChannel
252makeLenses ''EphemeralEditState
253
254isMuted :: ClientChannel -> Bool
255isMuted cc = cc^.ccInfo.cdNotifyProps.channelNotifyPropsMarkUnreadL ==
256             IsValue NotifyOptionMention
257
258notifyPreference :: User -> ClientChannel -> NotifyOption
259notifyPreference u cc =
260    if isMuted cc then NotifyOptionNone
261    else case cc^.ccInfo.cdNotifyProps.channelNotifyPropsDesktopL of
262             IsValue v -> v
263             Default   -> (userNotifyProps u)^.userNotifyPropsDesktopL
264
265-- ** Miscellaneous channel operations
266
267makeClientChannel :: (MonadIO m) => UserId -> Channel -> m ClientChannel
268makeClientChannel myId nc = emptyChannelContents >>= \contents ->
269  return ClientChannel
270  { _ccContents = contents
271  , _ccInfo = initialChannelInfo myId nc
272  , _ccEditState = defaultEphemeralEditState
273  }
274
275defaultEphemeralEditState :: EphemeralEditState
276defaultEphemeralEditState =
277    EphemeralEditState { _eesMultiline = False
278                       , _eesInputHistoryPosition = Nothing
279                       , _eesLastInput = ("", NewPost)
280                       }
281
282canLeaveChannel :: ChannelInfo -> Bool
283canLeaveChannel cInfo = not $ cInfo^.cdType `elem` [Direct]
284
285-- ** Manage the collection of all Channels
286
287-- | Define a binary kinded type to allow derivation of functor.
288data AllMyChannels a =
289    AllChannels { _chanMap :: HashMap ChannelId a
290                , _channelNameSet :: HashMap TeamId (S.Set Text)
291                , _userChannelMap :: HashMap UserId ChannelId
292                }
293                deriving (Functor, Foldable, Traversable)
294
295-- | Define the exported typename which universally binds the
296-- collection to the ChannelInfo type.
297type ClientChannels = AllMyChannels ClientChannel
298
299makeLenses ''AllMyChannels
300
301getChannelNameSet :: TeamId -> ClientChannels -> S.Set Text
302getChannelNameSet tId cs = case cs^.channelNameSet.at tId of
303    Nothing -> mempty
304    Just s -> s
305
306-- | Initial collection of Channels with no members
307noChannels :: ClientChannels
308noChannels = AllChannels HM.empty HM.empty HM.empty
309
310-- | Add a channel to the existing collection.
311addChannel :: ChannelId -> ClientChannel -> ClientChannels -> ClientChannels
312addChannel cId cinfo =
313    (chanMap %~ HM.insert cId cinfo) .
314    (if cinfo^.ccInfo.cdType `notElem` [Direct, Group]
315     then case cinfo^.ccInfo.cdTeamId of
316         Nothing -> id
317         Just tId -> channelNameSet %~ HM.insertWith S.union tId (S.singleton $ cinfo^.ccInfo.cdName)
318     else id) .
319    (case cinfo^.ccInfo.cdDMUserId of
320         Nothing -> id
321         Just uId -> userChannelMap %~ HM.insert uId cId
322    )
323
324-- | Remove a channel from the collection.
325removeChannel :: ChannelId -> ClientChannels -> ClientChannels
326removeChannel cId cs =
327    let mChan = findChannelById cId cs
328        removeChannelName = case mChan of
329            Nothing -> id
330            Just ch -> case ch^.ccInfo.cdTeamId of
331                Nothing -> id
332                Just tId -> channelNameSet %~ HM.adjust (S.delete (ch^.ccInfo.cdName)) tId
333    in cs & chanMap %~ HM.delete cId
334          & removeChannelName
335          & userChannelMap %~ HM.filter (/= cId)
336
337instance Semigroup (AllMyChannels ClientChannel) where
338    a <> b =
339        let pairs = HM.toList $ _chanMap a
340        in foldr (uncurry addChannel) b pairs
341
342instance Monoid (AllMyChannels ClientChannel) where
343    mempty = noChannels
344
345getDmChannelFor :: UserId -> ClientChannels -> Maybe ChannelId
346getDmChannelFor uId cs = cs^.userChannelMap.at uId
347
348allDmChannelMappings :: ClientChannels -> [(UserId, ChannelId)]
349allDmChannelMappings = HM.toList . _userChannelMap
350
351-- | Get the ChannelInfo information given the ChannelId
352findChannelById :: ChannelId -> ClientChannels -> Maybe ClientChannel
353findChannelById cId = HM.lookup cId . _chanMap
354
355-- | Transform the specified channel in place with provided function.
356modifyChannelById :: ChannelId -> (ClientChannel -> ClientChannel)
357                  -> ClientChannels -> ClientChannels
358modifyChannelById cId f = chanMap.ix(cId) %~ f
359
360-- | A 'Traversal' that will give us the 'ClientChannel' in a
361-- 'ClientChannels' structure if it exists
362channelByIdL :: ChannelId -> Traversal' ClientChannels ClientChannel
363channelByIdL cId = chanMap . ix cId
364
365-- | A 'Lens' that will give us the 'ClientChannel' in a
366-- 'ClientChannels' wrapped in a 'Maybe'
367maybeChannelByIdL :: ChannelId -> Lens' ClientChannels (Maybe ClientChannel)
368maybeChannelByIdL cId = chanMap . at cId
369
370-- | Apply a filter to each ClientChannel and return a list of the
371-- ChannelId values for which the filter matched.
372filteredChannelIds :: (ClientChannel -> Bool) -> ClientChannels -> [ChannelId]
373filteredChannelIds f cc = fst <$> filter (f . snd) (HM.toList (cc^.chanMap))
374
375-- | Get all the team IDs in the channel collection.
376allTeamIds :: ClientChannels -> [TeamId]
377allTeamIds cc = HM.keys $ cc^.channelNameSet
378
379-- | Filter the ClientChannel collection, keeping only those for which
380-- the provided filter test function returns True.
381filteredChannels :: ((ChannelId, ClientChannel) -> Bool)
382                 -> ClientChannels -> [(ChannelId, ClientChannel)]
383filteredChannels f cc = filter f $ cc^.chanMap.to HM.toList
384
385------------------------------------------------------------------------
386
387-- * Channel State management
388
389
390-- | Add user to the list of users in this channel who are currently typing.
391addChannelTypingUser :: UserId -> UTCTime -> ClientChannel -> ClientChannel
392addChannelTypingUser uId ts = ccInfo.cdTypingUsers %~ (addTypingUser uId ts)
393
394-- | Clear the new message indicator for the specified channel
395clearNewMessageIndicator :: ClientChannel -> ClientChannel
396clearNewMessageIndicator c = c & ccInfo.cdNewMessageIndicator .~ Hide
397
398-- | Clear the edit threshold for the specified channel
399clearEditedThreshold :: ClientChannel -> ClientChannel
400clearEditedThreshold c = c & ccInfo.cdEditedMessageThreshold .~ Nothing
401
402-- | Adjust updated time based on a message, ensuring that the updated
403-- time does not move backward.
404adjustUpdated :: Post -> ClientChannel -> ClientChannel
405adjustUpdated m =
406    ccInfo.cdUpdated %~ max (maxPostTimestamp m)
407
408adjustEditedThreshold :: Post -> ClientChannel -> ClientChannel
409adjustEditedThreshold m c =
410    if m^.postUpdateAtL <= m^.postCreateAtL
411    then c
412    else c & ccInfo.cdEditedMessageThreshold %~ (\mt -> case mt of
413        Just t -> Just $ min (m^.postUpdateAtL) t
414        Nothing -> Just $ m^.postUpdateAtL
415        )
416
417maxPostTimestamp :: Post -> ServerTime
418maxPostTimestamp m = max (m^.postDeleteAtL . non (m^.postUpdateAtL)) (m^.postCreateAtL)
419
420updateNewMessageIndicator :: Post -> ClientChannel -> ClientChannel
421updateNewMessageIndicator m =
422    ccInfo.cdNewMessageIndicator %~
423        (\old ->
424          case old of
425              Hide ->
426                  NewPostsStartingAt $ m^.postCreateAtL
427              NewPostsStartingAt ts ->
428                  NewPostsStartingAt $ min (m^.postCreateAtL) ts
429              NewPostsAfterServerTime ts ->
430                  if m^.postCreateAtL <= ts
431                  then NewPostsStartingAt $ m^.postCreateAtL
432                  else NewPostsAfterServerTime ts
433              )
434
435-- | Town Square is special in that its non-display name cannot be
436-- changed and is a hard-coded constant server-side according to the
437-- developers (as of 8/2/17). So this is a reliable way to check for
438-- whether a channel is in fact that channel, even if the user has
439-- changed its display name.
440isTownSquare :: Channel -> Bool
441isTownSquare c = (sanitizeUserText $ c^.channelNameL) == "town-square"
442
443channelDeleted :: Channel -> Bool
444channelDeleted c = c^.channelDeleteAtL > c^.channelCreateAtL
445