1{-# LANGUAGE RecordWildCards #-}
2{-# LANGUAGE LambdaCase #-}
3{-# LANGUAGE MultiWayIf #-}
4module Matterhorn.Draw.Messages
5  ( MessageData(..)
6  , renderMessage
7  , nameForUserRef
8  , renderSingleMessage
9  , unsafeRenderMessageSelection
10  , renderLastMessages
11  , addEllipsis
12  )
13where
14
15import           Brick
16import           Brick.Widgets.Border
17import           Control.Monad.Trans.Reader ( withReaderT )
18import qualified Data.Foldable as F
19import qualified Data.Map.Strict as Map
20import qualified Data.Sequence as S
21import           Data.Sequence ( ViewL(..)
22                               , ViewR(..)
23                               , (|>)
24                               , viewl
25                               , viewr)
26import qualified Data.Set as Set
27import qualified Data.Text as T
28import qualified Graphics.Vty as V
29import           Lens.Micro.Platform ( (.~), to )
30import           Network.Mattermost.Lenses ( postEditAtL, postCreateAtL )
31import           Network.Mattermost.Types ( ServerTime(..), userUsername, postId )
32import           Prelude ()
33import           Matterhorn.Prelude
34
35import           Matterhorn.Draw.Util
36import           Matterhorn.Draw.RichText
37import           Matterhorn.Themes
38import           Matterhorn.Types
39import           Matterhorn.Types.RichText
40import           Matterhorn.Types.DirectionalSeq
41
42maxMessageHeight :: Int
43maxMessageHeight = 200
44
45-- | nameForUserRef converts the UserRef into a printable name, based
46-- on the current known user data.
47nameForUserRef :: ChatState -> UserRef -> Maybe Text
48nameForUserRef st uref =
49    case uref of
50        NoUser -> Nothing
51        UserOverride _ t -> Just t
52        UserI _ uId -> displayNameForUserId uId st
53
54-- | renderSingleMessage is the main message drawing function.
55--
56-- The `ind` argument specifies an "indicator boundary".  Showing
57-- various indicators (e.g. "edited") is not typically done for
58-- messages that are older than this boundary value.
59renderSingleMessage :: ChatState
60                    -> HighlightSet
61                    -> Maybe ServerTime
62                    -> Message
63                    -> ThreadState
64                    -> Widget Name
65renderSingleMessage st hs ind m threadState =
66  renderChatMessage st hs ind threadState (withBrackets . renderTime st . withServerTime) m
67
68renderChatMessage :: ChatState
69                  -> HighlightSet
70                  -> Maybe ServerTime
71                  -> ThreadState
72                  -> (ServerTime -> Widget Name)
73                  -> Message
74                  -> Widget Name
75renderChatMessage st hs ind threadState renderTimeFunc msg =
76    let showOlderEdits = configShowOlderEdits config
77        showTimestamp = configShowMessageTimestamps config
78        config = st^.csResources.crConfiguration
79        parent = case msg^.mInReplyToMsg of
80          NotAReply -> Nothing
81          InReplyTo pId -> getMessageForPostId st pId
82        m = renderMessage MessageData
83              { mdMessage           = msg
84              , mdUserName          = msg^.mUser.to (nameForUserRef st)
85              , mdParentMessage     = parent
86              , mdParentUserName    = parent >>= (^.mUser.to (nameForUserRef st))
87              , mdEditThreshold     = ind
88              , mdHighlightSet      = hs
89              , mdShowOlderEdits    = showOlderEdits
90              , mdRenderReplyParent = True
91              , mdIndentBlocks      = True
92              , mdThreadState       = threadState
93              , mdShowReactions     = True
94              , mdMessageWidthLimit = Nothing
95              , mdMyUsername        = userUsername $ myUser st
96              , mdWrapNonhighlightedCodeBlocks = True
97              }
98        fullMsg =
99          case msg^.mUser of
100            NoUser
101              | isGap msg -> withDefAttr gapMessageAttr m
102              | otherwise ->
103                case msg^.mType of
104                    C DateTransition ->
105                        withDefAttr dateTransitionAttr (hBorderWithLabel m)
106                    C NewMessagesTransition ->
107                        withDefAttr newMessageTransitionAttr (hBorderWithLabel m)
108                    C Error ->
109                        withDefAttr errorMessageAttr m
110                    _ ->
111                        withDefAttr clientMessageAttr m
112            _ | isJoinLeave msg -> withDefAttr clientMessageAttr m
113              | otherwise -> m
114        maybeRenderTime w =
115            if showTimestamp
116            then let maybePadTime = if threadState == InThreadShowParent
117                                    then (txt " " <=>) else id
118                 in hBox [maybePadTime $ renderTimeFunc (msg^.mDate), txt " ", w]
119            else w
120        maybeRenderTimeWith f = if isTransition msg then id else f
121    in maybeRenderTimeWith maybeRenderTime fullMsg
122
123-- | Render a selected message with focus, including the messages
124-- before and the messages after it. The foldable parameters exist
125-- because (depending on the situation) we might use either of the
126-- message list types for the 'before' and 'after' (i.e. the
127-- chronological or retrograde message sequences).
128unsafeRenderMessageSelection :: (SeqDirection dir1, SeqDirection dir2)
129                             => ( (Message, ThreadState)
130                                , ( DirectionalSeq dir1 (Message, ThreadState)
131                                  , DirectionalSeq dir2 (Message, ThreadState)
132                                  )
133                                )
134                             -> (Message -> ThreadState -> Widget Name)
135                             -> Widget Name
136unsafeRenderMessageSelection ((curMsg, curThreadState), (before, after)) doMsgRender =
137  Widget Greedy Greedy $ do
138    ctx <- getContext
139    curMsgResult <- withReaderT relaxHeight $ render $
140                    forceAttr messageSelectAttr $
141                    padRight Max $ doMsgRender curMsg curThreadState
142
143    let targetHeight = ctx^.availHeightL
144        upperHeight = targetHeight `div` 2
145        lowerHeight = targetHeight - upperHeight
146
147    lowerHalfResults <- renderMessageSeq targetHeight (render1 doMsgRender) vLimit after
148    upperHalfResults <- renderMessageSeq targetHeight (render1 doMsgRender) cropTopTo before
149
150    let upperHalfResultsHeight = sum $ (V.imageHeight . image) <$> upperHalfResults
151        lowerHalfResultsHeight = sum $ (V.imageHeight . image) <$> lowerHalfResults
152        curHeight = V.imageHeight $ curMsgResult^.imageL
153        uncropped = vBox $ fmap resultToWidget $
154                           (reverse upperHalfResults) <> (curMsgResult : lowerHalfResults)
155
156        cropTop h w = Widget Fixed Fixed $ do
157            result <- withReaderT relaxHeight $ render w
158            render $ cropTopTo h $ resultToWidget result
159        cropBottom h w = Widget Fixed Fixed $ do
160            result <- withReaderT relaxHeight $ render w
161            render $ cropBottomTo h $ resultToWidget result
162
163        lowerHalf = vBox $ fmap resultToWidget lowerHalfResults
164        upperHalf = vBox $ fmap resultToWidget $ reverse upperHalfResults
165
166    render $ if | lowerHalfResultsHeight < (lowerHeight - curHeight) ->
167                    cropTop targetHeight uncropped
168                | upperHalfResultsHeight < upperHeight ->
169                    vLimit targetHeight uncropped
170                | otherwise ->
171                    cropTop upperHeight upperHalf <=> (resultToWidget curMsgResult) <=>
172                       (if curHeight < lowerHeight
173                         then cropBottom (lowerHeight - curHeight) lowerHalf
174                         else cropBottom lowerHeight lowerHalf)
175
176resultToWidget :: Result n -> Widget n
177resultToWidget = Widget Fixed Fixed . return
178
179renderMessageSeq :: (SeqDirection dir)
180                 => Int
181                 -> (Message -> ThreadState -> Widget Name)
182                 -> (Int -> Widget Name -> Widget Name)
183                 -> DirectionalSeq dir (Message, ThreadState)
184                 -> RenderM Name [Result Name]
185renderMessageSeq remainingHeight renderFunc limitFunc ms
186    | messagesLength ms == 0 = return []
187    | otherwise = do
188        let Just (m, threadState) = messagesHead ms
189            maybeCache = case m^.mMessageId of
190                Nothing -> id
191                Just i -> cached (RenderedMessage i)
192        result <- render $ limitFunc remainingHeight $ maybeCache $ renderFunc m threadState
193        rest <- renderMessageSeq (remainingHeight - (V.imageHeight $ result^.imageL)) renderFunc limitFunc (messagesDrop 1 ms)
194        return $ result : rest
195
196renderLastMessages :: ChatState
197                   -> HighlightSet
198                   -> Maybe ServerTime
199                   -> DirectionalSeq Retrograde (Message, ThreadState)
200                   -> Widget Name
201renderLastMessages st hs editCutoff msgs =
202    Widget Greedy Greedy $ do
203        ctx <- getContext
204        let targetHeight = ctx^.availHeightL
205            doMsgRender = renderSingleMessage st hs editCutoff
206
207            newMessagesTransitions = filterMessages (isNewMessagesTransition . fst) msgs
208            newMessageTransition = fst <$> (listToMaybe $ F.toList newMessagesTransitions)
209
210            isBelow m transition = m^.mDate > transition^.mDate
211
212            go :: Int -> DirectionalSeq Retrograde (Message, ThreadState) -> RenderM Name [Result Name]
213            go _ ms | messagesLength ms == 0 = return []
214            go remainingHeight ms = do
215                let Just (m, threadState) = messagesHead ms
216                    newMessagesAbove = maybe False (isBelow m) newMessageTransition
217
218                result <- render $ render1 doMsgRender m threadState
219
220                croppedResult <- render $ cropTopTo remainingHeight $ resultToWidget result
221
222                -- If the new message fills the window, check whether
223                -- there is still a "New Messages" transition that is
224                -- not displayed. If there is, then we need to replace
225                -- the top line of the new image with a "New Messages"
226                -- indicator.
227                if V.imageHeight (result^.imageL) >= remainingHeight
228                then do
229                    single <- if newMessagesAbove
230                              then do
231                                  result' <- render $
232                                      vBox [ withDefAttr newMessageTransitionAttr $ hBorderWithLabel (txt "New Messages ↑")
233                                           , cropTopBy 1 $ resultToWidget croppedResult
234                                           ]
235                                  return result'
236                              else do
237                                  return croppedResult
238                    return [single]
239                else do
240                    let unusedHeight = remainingHeight - V.imageHeight (result^.imageL)
241                    rest <- go unusedHeight $ messagesDrop 1 ms
242                    return $ result : rest
243
244        results <- go targetHeight msgs
245        render $ vBox $ (Widget Fixed Fixed . return) <$> reverse results
246
247relaxHeight :: Context -> Context
248relaxHeight c = c & availHeightL .~ (max maxMessageHeight (c^.availHeightL))
249
250render1 :: (Message -> ThreadState -> Widget Name)
251        -> Message
252        -> ThreadState
253        -> Widget Name
254render1 doMsgRender msg threadState = case msg^.mDeleted of
255    True -> emptyWidget
256    False ->
257        Widget Greedy Fixed $ do
258            withReaderT relaxHeight $
259                render $ padRight Max $
260                doMsgRender msg threadState
261
262-- | A bundled structure that includes all the information necessary
263-- to render a given message
264data MessageData =
265    MessageData { mdEditThreshold :: Maybe ServerTime
266                -- ^ If specified, any messages edited before this point
267                -- in time are not indicated as edited.
268                , mdShowOlderEdits :: Bool
269                -- ^ Indicates whether "edited" markers should be shown
270                -- for old messages (i.e., ignore the mdEditThreshold
271                -- value).
272                , mdShowReactions :: Bool
273                -- ^ Whether to render reactions.
274                , mdMessage :: Message
275                -- ^ The message to render.
276                , mdUserName :: Maybe Text
277                -- ^ The username of the message's author, if any. This
278                -- is passed here rather than obtaining from the message
279                -- because we need to do lookups in the ChatState to
280                -- compute this, and we don't pass the ChatState into
281                -- renderMessage.
282                , mdParentMessage :: Maybe Message
283                -- ^ The parent message of this message, if any.
284                , mdParentUserName :: Maybe Text
285                -- ^ The author of the parent message, if any.
286                , mdThreadState :: ThreadState
287                -- ^ The thread state of this message.
288                , mdRenderReplyParent :: Bool
289                -- ^ Whether to render the parent message.
290                , mdHighlightSet :: HighlightSet
291                -- ^ The highlight set to use to highlight usernames,
292                -- channel names, etc.
293                , mdIndentBlocks :: Bool
294                -- ^ Whether to indent the message underneath the
295                -- author's name (True) or just display it to the right
296                -- of the author's name (False).
297                , mdMessageWidthLimit :: Maybe Int
298                -- ^ A width override to use to wrap non-code blocks
299                -- and code blocks without syntax highlighting. If
300                -- unspecified, all blocks in the message will be
301                -- wrapped and truncated at the width specified by the
302                -- rendering context. If specified, all non-code blocks
303                -- will be wrapped at this width and highlighted code
304                -- blocks will be rendered using the context's width.
305                , mdMyUsername :: Text
306                -- ^ The username of the user running Matterhorn.
307                , mdWrapNonhighlightedCodeBlocks :: Bool
308                -- ^ Whether to wrap text in non-highlighted code
309                -- blocks.
310                }
311
312-- | renderMessage performs markdown rendering of the specified message.
313renderMessage :: MessageData -> Widget Name
314renderMessage md@MessageData { mdMessage = msg, .. } =
315    let msgUsr = case mdUserName of
316          Just u -> if omittedUsernameType (msg^.mType) then Nothing else Just u
317          Nothing -> Nothing
318        botElem = if isBotMessage msg then txt "[BOT]" else emptyWidget
319        mId = msg^.mMessageId
320        clickableAuthor un = case mId of
321            Nothing -> id
322            -- We use the index (-1) since indexes for clickable
323            -- usernames elsewhere in this message start at 0.
324            Just i -> clickable (ClickableUsernameInMessage i (-1) un)
325        nameElems = case msgUsr of
326          Just un
327            | isEmote msg ->
328                [ withDefAttr pinnedMessageIndicatorAttr $ txt $ if msg^.mPinned then "[PIN]" else ""
329                , txt $ (if msg^.mFlagged then "[!] " else "") <> "*"
330                , clickableAuthor un $ colorUsername mdMyUsername un un
331                , botElem
332                , txt " "
333                ]
334            | otherwise ->
335                [ withDefAttr pinnedMessageIndicatorAttr $ txt $ if msg^.mPinned then "[PIN] " else ""
336                , clickableAuthor un $ colorUsername mdMyUsername un un
337                , botElem
338                , txt $ (if msg^.mFlagged then "[!]" else "") <> ": "
339                ]
340          Nothing -> []
341
342        -- Use the editing threshold to determine whether to append an
343        -- editing indication to this message.
344        maybeAugment bs = case msg^.mOriginalPost of
345            Nothing -> bs
346            Just p ->
347                if p^.postEditAtL > p^.postCreateAtL
348                then case mdEditThreshold of
349                    Just cutoff | p^.postEditAtL >= cutoff ->
350                        addEditSentinel (EEditSentinel True) bs
351                    _ -> if mdShowOlderEdits
352                         then addEditSentinel (EEditSentinel False) bs
353                         else bs
354                else bs
355
356        augmentedText = unBlocks $ maybeAugment $ msg^.mText
357        msgWidget =
358            vBox $ (layout mdHighlightSet mdMessageWidthLimit nameElems augmentedText . viewl) augmentedText :
359                   catMaybes [msgAtch, msgReac]
360        replyIndent = Widget Fixed Fixed $ do
361            ctx <- getContext
362            -- NB: The amount subtracted here must be the total padding
363            -- added below (pad 1 + vBorder)
364            w <- render $ hLimit (ctx^.availWidthL - 2) msgWidget
365            render $ vLimit (V.imageHeight $ w^.imageL) $
366                padRight (Pad 1) vBorder <+> (Widget Fixed Fixed $ return w)
367        msgAtch = if S.null (msg^.mAttachments)
368          then Nothing
369          else Just $ withDefAttr clientMessageAttr $ vBox
370                 [ txt ("  [attached: `" <> a^.attachmentName <> "`]")
371                 | a <- toList (msg^.mAttachments)
372                 ]
373        msgReac = if Map.null (msg^.mReactions) || (not mdShowReactions)
374          then Nothing
375          else let renderR e us lst =
376                       let n = Set.size us
377                       in if | n == 1    -> makeReactionWidget e us (" [" <> e <> "]") : lst
378                             | otherwise -> makeReactionWidget e us (" [" <> e <> " " <> T.pack (show n) <> "]") : lst
379                   nonEmptyReactions = Map.filter (not . Set.null) $ msg^.mReactions
380                   makeReactionWidget e us t =
381                       let w = txt t in
382                       maybe w (flip clickable w) $ makeName e us
383                   hasAnyReactions = not $ null nonEmptyReactions
384                   makeName e us = do
385                       pid <- postId <$> msg^.mOriginalPost
386                       Just $ ClickableReactionInMessage pid e us
387                   reactionWidget = Widget Fixed Fixed $ do
388                       ctx <- getContext
389                       let lineW = ctx^.availWidthL
390                       reacs <- mapM render $ Map.foldrWithKey renderR [] nonEmptyReactions
391                       let reacLines :: [Result n] -> Int -> [Result n] -> [[Result n]]
392                           reacLines l _ []     = if null l then [] else [l]
393                           reacLines l w (r:rs) =
394                               let rW = V.imageWidth $ r^.imageL
395                               in if rW <= w
396                                  then reacLines (l <> [r]) (w - rW) rs
397                                  else
398                                      let rest = reacLines [] lineW rs
399                                      in l : [r] : rest
400
401                       render $ vBox $ hBox <$> (fmap (fmap resultToWidget)) (reacLines [] lineW reacs)
402               in if hasAnyReactions
403                  then Just $ withDefAttr emojiAttr $ txt "   " <+> reactionWidget
404                  else Nothing
405        withParent p =
406            case mdThreadState of
407                NoThread -> msgWidget
408                InThreadShowParent -> p <=> replyIndent
409                InThread -> replyIndent
410    in if not mdRenderReplyParent
411       then msgWidget
412       else case msg^.mInReplyToMsg of
413          NotAReply -> msgWidget
414          InReplyTo _ ->
415              case mdParentMessage of
416                  Nothing -> withParent (str "[loading...]")
417                  Just pm ->
418                      let parentMsg = renderMessage md
419                            { mdShowOlderEdits    = False
420                            , mdMessage           = pm
421                            , mdUserName          = mdParentUserName
422                            , mdParentMessage     = Nothing
423                            , mdRenderReplyParent = False
424                            , mdIndentBlocks      = False
425                            }
426                      in withParent (addEllipsis $ forceAttr replyParentAttr parentMsg)
427
428    where
429        layout :: HighlightSet -> Maybe Int -> [Widget Name] -> Seq Block
430               -> ViewL Block -> Widget Name
431        layout hs w nameElems bs xs | length xs > 1     = multiLnLayout hs w nameElems bs
432        layout hs w nameElems bs (Blockquote {} :< _) = multiLnLayout hs w nameElems bs
433        layout hs w nameElems bs (CodeBlock {} :< _)  = multiLnLayout hs w nameElems bs
434        layout hs w nameElems bs (HTMLBlock {} :< _)  = multiLnLayout hs w nameElems bs
435        layout hs w nameElems bs (List {} :< _)       = multiLnLayout hs w nameElems bs
436        layout hs w nameElems bs (Para inlns :< _)
437            | F.any breakCheck (unInlines inlns)      = multiLnLayout hs w nameElems bs
438        layout hs w nameElems bs _                    = nameNextToMessage hs w nameElems bs
439
440        multiLnLayout hs w nameElems bs =
441            if mdIndentBlocks
442               then vBox [ hBox nameElems
443                         , hBox [txt "  ", renderRichText mdMyUsername hs ((subtract 2) <$> w)
444                                                 mdWrapNonhighlightedCodeBlocks (Just clickableNames) (Blocks bs)]
445                         ]
446               else nameNextToMessage hs w nameElems bs
447
448        nameNextToMessage hs w nameElems bs =
449            Widget Fixed Fixed $ do
450                nameResult <- render $ hBox nameElems
451                let newW = subtract (V.imageWidth (nameResult^.imageL)) <$> w
452                render $ hBox [ Widget Fixed Fixed $ return nameResult
453                              , renderRichText mdMyUsername hs newW mdWrapNonhighlightedCodeBlocks (Just clickableNames) (Blocks bs)
454                              ]
455
456        breakCheck i = i `elem` [ELineBreak, ESoftBreak]
457
458        clickableNames i (EHyperlink u _) =
459            case msg^.mMessageId of
460                Just mId -> Just $ ClickableURLInMessage mId i $ LinkURL u
461                Nothing -> Nothing
462        clickableNames i (EUser name) =
463            case msg^.mMessageId of
464                Just mId -> Just $ ClickableUsernameInMessage mId i name
465                Nothing -> Nothing
466        clickableNames _ _ = Nothing
467
468-- Add the edit sentinel to the end of the last block in the sequence.
469-- If the last block is a paragraph, append it to that paragraph.
470-- Otherwise, append a new block so it appears beneath the last
471-- block-level element.
472addEditSentinel :: Inline -> Blocks -> Blocks
473addEditSentinel d (Blocks bs) =
474    case viewr bs of
475        EmptyR -> Blocks bs
476        (rest :> b) -> Blocks rest <> appendEditSentinel d b
477
478appendEditSentinel :: Inline -> Block -> Blocks
479appendEditSentinel sentinel b =
480    let s = Para (Inlines $ S.singleton sentinel)
481    in Blocks $ case b of
482        Para is -> S.singleton $ Para (Inlines $ unInlines is |> ESpace |> sentinel)
483        _ -> S.fromList [b, s]
484
485omittedUsernameType :: MessageType -> Bool
486omittedUsernameType = \case
487    CP Join -> True
488    CP Leave -> True
489    CP TopicChange -> True
490    _ -> False
491
492addEllipsis :: Widget a -> Widget a
493addEllipsis w = Widget (hSize w) (vSize w) $ do
494    ctx <- getContext
495    let aw = ctx^.availWidthL
496    result <- render w
497    let withEllipsis = (hLimit (aw - 3) $ vLimit 1 $ (Widget Fixed Fixed $ return result)) <+>
498                       str "..."
499    if (V.imageHeight (result^.imageL) > 1) || (V.imageWidth (result^.imageL) == aw) then
500        render withEllipsis else
501        return result
502