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