{-# LANGUAGE MultiWayIf #-}
{-# LANGUAGE TemplateHaskell #-}
module Matterhorn.Types.Posts
  ( ClientMessage
  , newClientMessage
  , cmDate
  , cmType
  , cmText

  , ClientMessageType(..)

  , Attachment
  , mkAttachment
  , attachmentName
  , attachmentFileId
  , attachmentURL

  , ClientPostType(..)

  , ClientPost
  , toClientPost
  , cpUserOverride
  , cpMarkdownSource
  , cpUser
  , cpText
  , cpType
  , cpReactions
  , cpPending
  , cpOriginalPost
  , cpFromWebhook
  , cpInReplyToPost
  , cpDate
  , cpChannelId
  , cpAttachments
  , cpDeleted
  , cpPostId
  , cpPinned

  , unEmote

  , postIsLeave
  , postIsJoin
  , postIsTopicChange
  , postIsEmote
  )
where

import           Prelude ()
import           Matterhorn.Prelude

import qualified Data.Foldable as F
import qualified Data.Map.Strict as Map
import qualified Data.Sequence as Seq
import qualified Data.Text as T
import qualified Data.Set as S
import           Data.Time.Clock ( getCurrentTime )
import           Lens.Micro.Platform ( makeLenses )

import           Network.Mattermost.Lenses
import           Network.Mattermost.Types

import           Matterhorn.Types.Common
import           Matterhorn.Types.RichText ( Blocks(..), Block(..)
                                           , TeamBaseURL, Inlines(..), Inline(..)
                                           , ListType(..), ListSpacing(..)
                                           , parseMarkdown, singleB, singleI
                                           )


-- * Client Messages

-- | A 'ClientMessage' is a message given to us by our client,
--   like help text or an error message.
data ClientMessage = ClientMessage
  { ClientMessage -> Text
_cmText :: Text
  , ClientMessage -> ServerTime
_cmDate :: ServerTime
  , ClientMessage -> ClientMessageType
_cmType :: ClientMessageType
  } deriving (Int -> ClientMessage -> ShowS
[ClientMessage] -> ShowS
ClientMessage -> String
forall a.
(Int -> a -> ShowS) -> (a -> String) -> ([a] -> ShowS) -> Show a
showList :: [ClientMessage] -> ShowS
$cshowList :: [ClientMessage] -> ShowS
show :: ClientMessage -> String
$cshow :: ClientMessage -> String
showsPrec :: Int -> ClientMessage -> ShowS
$cshowsPrec :: Int -> ClientMessage -> ShowS
Show)

-- | Create a new 'ClientMessage' value.  This is a message generated
-- by this Matterhorn client and not by (or visible to) the Server.
-- These should be visible, but not necessarily integrated into any
-- special position in the output stream (i.e., they should generally
-- appear at the bottom of the messages display, but subsequent
-- messages should follow them), so this is a special place where
-- there is an assumed approximation of equality between local time
-- and server time.
newClientMessage :: (MonadIO m) => ClientMessageType -> Text -> m ClientMessage
newClientMessage :: forall (m :: * -> *).
MonadIO m =>
ClientMessageType -> Text -> m ClientMessage
newClientMessage ClientMessageType
ty Text
msg = do
  UTCTime
now <- forall (m :: * -> *) a. MonadIO m => IO a -> m a
liftIO IO UTCTime
getCurrentTime
  forall (m :: * -> *) a. Monad m => a -> m a
return (Text -> ServerTime -> ClientMessageType -> ClientMessage
ClientMessage Text
msg (UTCTime -> ServerTime
ServerTime UTCTime
now) ClientMessageType
ty)

-- | We format 'ClientMessage' values differently depending on
--   their 'ClientMessageType'
data ClientMessageType =
    Informative
    | Error
    | DateTransition
    | NewMessagesTransition
    | UnknownGapBefore -- ^ a region where the server may have
                       -- messages before the given timestamp that are
                       -- not known locally by this client
    | UnknownGapAfter  -- ^ a region where server may have messages
                       -- after the given timestamp that are not known
                       -- locally by this client
    deriving (Int -> ClientMessageType -> ShowS
[ClientMessageType] -> ShowS
ClientMessageType -> String
forall a.
(Int -> a -> ShowS) -> (a -> String) -> ([a] -> ShowS) -> Show a
showList :: [ClientMessageType] -> ShowS
$cshowList :: [ClientMessageType] -> ShowS
show :: ClientMessageType -> String
$cshow :: ClientMessageType -> String
showsPrec :: Int -> ClientMessageType -> ShowS
$cshowsPrec :: Int -> ClientMessageType -> ShowS
Show, ClientMessageType -> ClientMessageType -> Bool
forall a. (a -> a -> Bool) -> (a -> a -> Bool) -> Eq a
/= :: ClientMessageType -> ClientMessageType -> Bool
$c/= :: ClientMessageType -> ClientMessageType -> Bool
== :: ClientMessageType -> ClientMessageType -> Bool
$c== :: ClientMessageType -> ClientMessageType -> Bool
Eq)

-- ** 'ClientMessage' Lenses

makeLenses ''ClientMessage

-- * Mattermost Posts

-- | A 'ClientPost' is a temporary internal representation of
--   the Mattermost 'Post' type, with unnecessary information
--   removed and some preprocessing done.
data ClientPost = ClientPost
  { ClientPost -> Blocks
_cpText          :: Blocks
  , ClientPost -> Text
_cpMarkdownSource :: Text
  , ClientPost -> Maybe UserId
_cpUser          :: Maybe UserId
  , ClientPost -> Maybe Text
_cpUserOverride  :: Maybe Text
  , ClientPost -> ServerTime
_cpDate          :: ServerTime
  , ClientPost -> ClientPostType
_cpType          :: ClientPostType
  , ClientPost -> Bool
_cpPending       :: Bool
  , ClientPost -> Bool
_cpDeleted       :: Bool
  , ClientPost -> Seq Attachment
_cpAttachments   :: Seq Attachment
  , ClientPost -> Maybe PostId
_cpInReplyToPost :: Maybe PostId
  , ClientPost -> PostId
_cpPostId        :: PostId
  , ClientPost -> ChannelId
_cpChannelId     :: ChannelId
  , ClientPost -> Map Text (Set UserId)
_cpReactions     :: Map.Map Text (S.Set UserId)
  , ClientPost -> Post
_cpOriginalPost  :: Post
  , ClientPost -> Bool
_cpFromWebhook   :: Bool
  , ClientPost -> Bool
_cpPinned        :: Bool
  } deriving (Int -> ClientPost -> ShowS
[ClientPost] -> ShowS
ClientPost -> String
forall a.
(Int -> a -> ShowS) -> (a -> String) -> ([a] -> ShowS) -> Show a
showList :: [ClientPost] -> ShowS
$cshowList :: [ClientPost] -> ShowS
show :: ClientPost -> String
$cshow :: ClientPost -> String
showsPrec :: Int -> ClientPost -> ShowS
$cshowsPrec :: Int -> ClientPost -> ShowS
Show)

-- | An attachment has a very long URL associated, as well as
--   an actual file URL
data Attachment = Attachment
  { Attachment -> Text
_attachmentName   :: Text
  , Attachment -> Text
_attachmentURL    :: Text
  , Attachment -> FileId
_attachmentFileId :: FileId
  } deriving (Attachment -> Attachment -> Bool
forall a. (a -> a -> Bool) -> (a -> a -> Bool) -> Eq a
/= :: Attachment -> Attachment -> Bool
$c/= :: Attachment -> Attachment -> Bool
== :: Attachment -> Attachment -> Bool
$c== :: Attachment -> Attachment -> Bool
Eq, Int -> Attachment -> ShowS
[Attachment] -> ShowS
Attachment -> String
forall a.
(Int -> a -> ShowS) -> (a -> String) -> ([a] -> ShowS) -> Show a
showList :: [Attachment] -> ShowS
$cshowList :: [Attachment] -> ShowS
show :: Attachment -> String
$cshow :: Attachment -> String
showsPrec :: Int -> Attachment -> ShowS
$cshowsPrec :: Int -> Attachment -> ShowS
Show)

mkAttachment :: Text -> Text -> FileId -> Attachment
mkAttachment :: Text -> Text -> FileId -> Attachment
mkAttachment = Text -> Text -> FileId -> Attachment
Attachment

-- | A Mattermost 'Post' value can represent either a normal
--   chat message or one of several special events.
data ClientPostType =
    NormalPost
    | Emote
    | Join
    | Leave
    | TopicChange
    deriving (ClientPostType -> ClientPostType -> Bool
forall a. (a -> a -> Bool) -> (a -> a -> Bool) -> Eq a
/= :: ClientPostType -> ClientPostType -> Bool
$c/= :: ClientPostType -> ClientPostType -> Bool
== :: ClientPostType -> ClientPostType -> Bool
$c== :: ClientPostType -> ClientPostType -> Bool
Eq, Int -> ClientPostType -> ShowS
[ClientPostType] -> ShowS
ClientPostType -> String
forall a.
(Int -> a -> ShowS) -> (a -> String) -> ([a] -> ShowS) -> Show a
showList :: [ClientPostType] -> ShowS
$cshowList :: [ClientPostType] -> ShowS
show :: ClientPostType -> String
$cshow :: ClientPostType -> String
showsPrec :: Int -> ClientPostType -> ShowS
$cshowsPrec :: Int -> ClientPostType -> ShowS
Show)

-- ** Creating 'ClientPost' Values

-- | Determine the internal 'PostType' based on a 'Post'
postClientPostType :: Post -> ClientPostType
postClientPostType :: Post -> ClientPostType
postClientPostType Post
cp =
    if | Post -> Bool
postIsEmote Post
cp       -> ClientPostType
Emote
       | Post -> Bool
postIsJoin  Post
cp       -> ClientPostType
Join
       | Post -> Bool
postIsLeave Post
cp       -> ClientPostType
Leave
       | Post -> Bool
postIsTopicChange Post
cp -> ClientPostType
TopicChange
       | Bool
otherwise            -> ClientPostType
NormalPost

-- | Find out whether a 'Post' represents a topic change
postIsTopicChange :: Post -> Bool
postIsTopicChange :: Post -> Bool
postIsTopicChange Post
p = Post -> PostType
postType Post
p forall a. Eq a => a -> a -> Bool
== PostType
PostTypeHeaderChange

-- | Find out whether a 'Post' is from a @/me@ command
postIsEmote :: Post -> Bool
postIsEmote :: Post -> Bool
postIsEmote Post
p =
    forall (t :: * -> *). Foldable t => t Bool -> Bool
and [ Post
pforall s a. s -> Getting a s a -> a
^.Lens' Post PostProps
postPropsLforall b c a. (b -> c) -> (a -> b) -> a -> c
.Lens' PostProps (Maybe Text)
postPropsOverrideIconUrlL forall a. Eq a => a -> a -> Bool
== forall a. a -> Maybe a
Just (Text
""::Text)
        , (Text
"*" Text -> Text -> Bool
`T.isPrefixOf` (UserText -> Text
sanitizeUserText forall a b. (a -> b) -> a -> b
$ Post -> UserText
postMessage Post
p))
        , (Text
"*" Text -> Text -> Bool
`T.isSuffixOf` (UserText -> Text
sanitizeUserText forall a b. (a -> b) -> a -> b
$ Post -> UserText
postMessage Post
p))
        ]

-- | Find out whether a 'Post' is a user joining a channel
postIsJoin :: Post -> Bool
postIsJoin :: Post -> Bool
postIsJoin Post
p =
  Post
pforall s a. s -> Getting a s a -> a
^.Lens' Post PostType
postTypeL forall a. Eq a => a -> a -> Bool
== PostType
PostTypeJoinChannel

-- | Find out whether a 'Post' is a user leaving a channel
postIsLeave :: Post -> Bool
postIsLeave :: Post -> Bool
postIsLeave Post
p =
  Post
pforall s a. s -> Getting a s a -> a
^.Lens' Post PostType
postTypeL forall a. Eq a => a -> a -> Bool
== PostType
PostTypeLeaveChannel

-- | Undo the automatic formatting of posts generated by @/me@-commands
unEmote :: ClientPostType -> Text -> Text
unEmote :: ClientPostType -> Text -> Text
unEmote ClientPostType
Emote Text
t = if Text
"*" Text -> Text -> Bool
`T.isPrefixOf` Text
t Bool -> Bool -> Bool
&& Text
"*" Text -> Text -> Bool
`T.isSuffixOf` Text
t
                  then Text -> Text
T.init forall a b. (a -> b) -> a -> b
$ Text -> Text
T.tail Text
t
                  else Text
t
unEmote ClientPostType
_ Text
t = Text
t

attachmentFromFileInfo :: T.Text -> FileInfo -> Attachment
attachmentFromFileInfo :: Text -> FileInfo -> Attachment
attachmentFromFileInfo Text
hostname FileInfo
info =
    let scheme :: Text
scheme = Text
"https://"
        attUrl :: Text
attUrl = Text
scheme forall a. Semigroup a => a -> a -> a
<> Text
hostname forall a. Semigroup a => a -> a -> a
<> FileId -> Text
urlForFile FileId
fId
        fId :: FileId
fId = FileInfo -> FileId
fileInfoId FileInfo
info
    in Text -> Text -> FileId -> Attachment
mkAttachment (FileInfo -> Text
fileInfoName FileInfo
info) Text
attUrl FileId
fId

-- | Convert a Mattermost 'Post' to a 'ClientPost', passing in a
--   'ParentId' if it has a known one.
toClientPost :: T.Text -> Maybe TeamBaseURL -> Post -> Maybe PostId -> ClientPost
toClientPost :: Text -> Maybe TeamBaseURL -> Post -> Maybe PostId -> ClientPost
toClientPost Text
hostname Maybe TeamBaseURL
baseUrl Post
p Maybe PostId
parentId =
  let src :: Text
src = ClientPostType -> Text -> Text
unEmote (Post -> ClientPostType
postClientPostType Post
p) forall a b. (a -> b) -> a -> b
$ UserText -> Text
sanitizeUserText forall a b. (a -> b) -> a -> b
$ Post -> UserText
postMessage Post
p
  in ClientPost { _cpText :: Blocks
_cpText          = Maybe TeamBaseURL -> Text -> Blocks
parseMarkdown Maybe TeamBaseURL
baseUrl Text
src forall a. Semigroup a => a -> a -> a
<> Post -> Blocks
getAttachmentText Post
p
                , _cpMarkdownSource :: Text
_cpMarkdownSource = Text
src
                , _cpUser :: Maybe UserId
_cpUser          = Post -> Maybe UserId
postUserId Post
p
                , _cpUserOverride :: Maybe Text
_cpUserOverride  = Post
pforall s a. s -> Getting a s a -> a
^.Lens' Post PostProps
postPropsLforall b c a. (b -> c) -> (a -> b) -> a -> c
.Lens' PostProps (Maybe Text)
postPropsOverrideUsernameL
                , _cpDate :: ServerTime
_cpDate          = Post -> ServerTime
postCreateAt Post
p
                , _cpType :: ClientPostType
_cpType          = Post -> ClientPostType
postClientPostType Post
p
                , _cpPending :: Bool
_cpPending       = Bool
False
                , _cpDeleted :: Bool
_cpDeleted       = Bool
False
                , _cpPinned :: Bool
_cpPinned        = forall a. a -> Maybe a -> a
fromMaybe Bool
False forall a b. (a -> b) -> a -> b
$ Post -> Maybe Bool
postPinned Post
p
                , _cpAttachments :: Seq Attachment
_cpAttachments   = Text -> FileInfo -> Attachment
attachmentFromFileInfo Text
hostname forall (f :: * -> *) a b. Functor f => (a -> b) -> f a -> f b
<$> PostMetadata -> Seq FileInfo
postMetadataFiles (Post -> PostMetadata
postMetadata Post
p)
                , _cpInReplyToPost :: Maybe PostId
_cpInReplyToPost = Maybe PostId
parentId
                , _cpPostId :: PostId
_cpPostId        = Post
pforall s a. s -> Getting a s a -> a
^.Lens' Post PostId
postIdL
                , _cpChannelId :: ChannelId
_cpChannelId     = Post
pforall s a. s -> Getting a s a -> a
^.Lens' Post ChannelId
postChannelIdL
                , _cpReactions :: Map Text (Set UserId)
_cpReactions     = Seq Reaction -> Map Text (Set UserId)
mkReactionMap forall a b. (a -> b) -> a -> b
$ PostMetadata -> Seq Reaction
postMetadataReactions (Post -> PostMetadata
postMetadata Post
p)
                , _cpOriginalPost :: Post
_cpOriginalPost  = Post
p
                , _cpFromWebhook :: Bool
_cpFromWebhook   = forall a. a -> Maybe a -> a
fromMaybe Bool
False forall a b. (a -> b) -> a -> b
$ Post
pforall s a. s -> Getting a s a -> a
^.Lens' Post PostProps
postPropsLforall b c a. (b -> c) -> (a -> b) -> a -> c
.Lens' PostProps (Maybe Bool)
postPropsFromWebhookL
                }

mkReactionMap :: Seq Reaction -> Map.Map T.Text (S.Set UserId)
mkReactionMap :: Seq Reaction -> Map Text (Set UserId)
mkReactionMap Seq Reaction
rs =
    let inserter :: Reaction -> Map Text (Set UserId) -> Map Text (Set UserId)
inserter Reaction
r Map Text (Set UserId)
m = forall k a. Ord k => (a -> a -> a) -> k -> a -> Map k a -> Map k a
Map.insertWith forall a. Ord a => Set a -> Set a -> Set a
S.union (Reaction -> Text
reactionEmojiName Reaction
r) (forall a. a -> Set a
S.singleton forall a b. (a -> b) -> a -> b
$ Reaction -> UserId
reactionUserId Reaction
r) Map Text (Set UserId)
m
    in forall (t :: * -> *) a b.
Foldable t =>
(a -> b -> b) -> b -> t a -> b
F.foldr Reaction -> Map Text (Set UserId) -> Map Text (Set UserId)
inserter forall a. Monoid a => a
mempty Seq Reaction
rs

-- | Right now, instead of treating 'attachment' properties specially, we're
--   just going to roll them directly into the message text
getAttachmentText :: Post -> Blocks
getAttachmentText :: Post -> Blocks
getAttachmentText Post
p =
  case Post
pforall s a. s -> Getting a s a -> a
^.Lens' Post PostProps
postPropsLforall b c a. (b -> c) -> (a -> b) -> a -> c
.Lens' PostProps (Maybe (Seq PostPropAttachment))
postPropsAttachmentsL of
    Maybe (Seq PostPropAttachment)
Nothing -> forall a. Monoid a => a
mempty
    Just Seq PostPropAttachment
attachments ->
      Seq Block -> Blocks
Blocks forall a b. (a -> b) -> a -> b
$ forall (f :: * -> *) a b. Functor f => (a -> b) -> f a -> f b
fmap (Blocks -> Block
Blockquote forall b c a. (b -> c) -> (a -> b) -> a -> c
. PostPropAttachment -> Blocks
render) Seq PostPropAttachment
attachments
  where render :: PostPropAttachment -> Blocks
render PostPropAttachment
att = Maybe TeamBaseURL -> Text -> Blocks
parseMarkdown forall a. Maybe a
Nothing (PostPropAttachment
attforall s a. s -> Getting a s a -> a
^.Lens' PostPropAttachment Text
ppaTextL) forall a. Semigroup a => a -> a -> a
<>
                     Maybe TeamBaseURL -> Text -> Blocks
parseMarkdown forall a. Maybe a
Nothing (PostPropAttachment
attforall s a. s -> Getting a s a -> a
^.Lens' PostPropAttachment Text
ppaFallbackL) forall a. Semigroup a => a -> a -> a
<>
                     Seq PostPropAttachmentField -> Blocks
renderAttFields (PostPropAttachment
attforall s a. s -> Getting a s a -> a
^.Lens' PostPropAttachment (Seq PostPropAttachmentField)
ppaFieldsL)

-- | Render a bulleted list with any text fields that the post may have
--   attached to it
renderAttFields :: Seq PostPropAttachmentField -> Blocks
renderAttFields :: Seq PostPropAttachmentField -> Blocks
renderAttFields Seq PostPropAttachmentField
fs = Block -> Blocks
singleB forall a b. (a -> b) -> a -> b
$
                     ListType -> ListSpacing -> Seq Blocks -> Block
List (Char -> ListType
BulletList Char
'*') ListSpacing
LooseList forall a b. (a -> b) -> a -> b
$
                     forall (f :: * -> *) a b. Functor f => (a -> b) -> f a -> f b
fmap PostPropAttachmentField -> Blocks
renderAttFieldItem Seq PostPropAttachmentField
fs

-- | Each item will be rendered as the field name in boldface and the value
--   right below it
renderAttFieldItem :: PostPropAttachmentField -> Blocks
renderAttFieldItem :: PostPropAttachmentField -> Blocks
renderAttFieldItem PostPropAttachmentField
f = Block -> Blocks
singleB forall a b. (a -> b) -> a -> b
$ Inlines -> Block
Para forall a b. (a -> b) -> a -> b
$ PostPropAttachmentField -> Inlines
renderAttFieldItemContent PostPropAttachmentField
f

renderAttFieldItemContent :: PostPropAttachmentField -> Inlines
renderAttFieldItemContent :: PostPropAttachmentField -> Inlines
renderAttFieldItemContent PostPropAttachmentField
f = Seq Inline -> Inlines
Inlines forall a b. (a -> b) -> a -> b
$ forall a. [a] -> Seq a
Seq.fromList forall a b. (a -> b) -> a -> b
$
                              PostPropAttachmentField -> [Inline]
renderAttFieldItemName PostPropAttachmentField
f forall a. Semigroup a => a -> a -> a
<>
                              [Text -> Inline
EText forall a b. (a -> b) -> a -> b
$ PostPropAttachmentField -> Text
ppafValue PostPropAttachmentField
f]

-- | The field name can sometimes be empty
renderAttFieldItemName :: PostPropAttachmentField -> [Inline]
renderAttFieldItemName :: PostPropAttachmentField -> [Inline]
renderAttFieldItemName PostPropAttachmentField
f =
  if PostPropAttachmentField -> Text
ppafTitle PostPropAttachmentField
f forall a. Eq a => a -> a -> Bool
== Text
T.empty
  then []
  else [Inlines -> Inline
EStrong forall a b. (a -> b) -> a -> b
$ Inline -> Inlines
singleI forall a b. (a -> b) -> a -> b
$ Text -> Inline
EText forall a b. (a -> b) -> a -> b
$ PostPropAttachmentField -> Text
ppafTitle PostPropAttachmentField
f, Inline
ELineBreak]

-- ** 'ClientPost' Lenses

makeLenses ''Attachment
makeLenses ''ClientPost