{-# 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.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 ( RichTextBlock(Blockquote), parseMarkdown
, TeamBaseURL
)
data ClientMessage = ClientMessage
{ _cmText :: Text
, _cmDate :: ServerTime
, _cmType :: ClientMessageType
} deriving (Show)
newClientMessage :: (MonadIO m) => ClientMessageType -> Text -> m ClientMessage
newClientMessage ty msg = do
now <- liftIO getCurrentTime
return (ClientMessage msg (ServerTime now) ty)
data ClientMessageType =
Informative
| Error
| DateTransition
| NewMessagesTransition
| UnknownGapBefore
| UnknownGapAfter
deriving (Show)
makeLenses ''ClientMessage
data ClientPost = ClientPost
{ _cpText :: Seq RichTextBlock
, _cpMarkdownSource :: Text
, _cpUser :: Maybe UserId
, _cpUserOverride :: Maybe Text
, _cpDate :: ServerTime
, _cpType :: ClientPostType
, _cpPending :: Bool
, _cpDeleted :: Bool
, _cpAttachments :: Seq Attachment
, _cpInReplyToPost :: Maybe PostId
, _cpPostId :: PostId
, _cpChannelId :: ChannelId
, _cpReactions :: Map.Map Text (S.Set UserId)
, _cpOriginalPost :: Post
, _cpFromWebhook :: Bool
, _cpPinned :: Bool
} deriving (Show)
data Attachment = Attachment
{ _attachmentName :: Text
, _attachmentURL :: Text
, _attachmentFileId :: FileId
} deriving (Eq, Show)
mkAttachment :: Text -> Text -> FileId -> Attachment
mkAttachment = Attachment
data ClientPostType =
NormalPost
| Emote
| Join
| Leave
| TopicChange
deriving (Eq, Show)
postClientPostType :: Post -> ClientPostType
postClientPostType cp =
if | postIsEmote cp -> Emote
| postIsJoin cp -> Join
| postIsLeave cp -> Leave
| postIsTopicChange cp -> TopicChange
| otherwise -> NormalPost
postIsTopicChange :: Post -> Bool
postIsTopicChange p = postType p == PostTypeHeaderChange
postIsEmote :: Post -> Bool
postIsEmote p =
and [ p^.postPropsL.postPropsOverrideIconUrlL == Just (""::Text)
, ("*" `T.isPrefixOf` (sanitizeUserText $ postMessage p))
, ("*" `T.isSuffixOf` (sanitizeUserText $ postMessage p))
]
postIsJoin :: Post -> Bool
postIsJoin p =
p^.postTypeL == PostTypeJoinChannel
postIsLeave :: Post -> Bool
postIsLeave p =
p^.postTypeL == PostTypeLeaveChannel
unEmote :: ClientPostType -> Text -> Text
unEmote Emote t = if "*" `T.isPrefixOf` t && "*" `T.isSuffixOf` t
then T.init $ T.tail t
else t
unEmote _ t = t
toClientPost :: TeamBaseURL -> Post -> Maybe PostId -> ClientPost
toClientPost baseUrl p parentId =
let src = unEmote (postClientPostType p) $ sanitizeUserText $ postMessage p
in ClientPost { _cpText = parseMarkdown (Just baseUrl) src <> getAttachmentText p
, _cpMarkdownSource = src
, _cpUser = postUserId p
, _cpUserOverride = p^.postPropsL.postPropsOverrideUsernameL
, _cpDate = postCreateAt p
, _cpType = postClientPostType p
, _cpPending = False
, _cpDeleted = False
, _cpPinned = fromMaybe False $ postPinned p
, _cpAttachments = Seq.empty
, _cpInReplyToPost = parentId
, _cpPostId = p^.postIdL
, _cpChannelId = p^.postChannelIdL
, _cpReactions = Map.empty
, _cpOriginalPost = p
, _cpFromWebhook = fromMaybe False $ p^.postPropsL.postPropsFromWebhookL
}
getAttachmentText :: Post -> Seq RichTextBlock
getAttachmentText p =
case p^.postPropsL.postPropsAttachmentsL of
Nothing -> Seq.empty
Just attachments ->
fmap (Blockquote . render) attachments
where render att = parseMarkdown Nothing (att^.ppaTextL) <>
parseMarkdown Nothing (att^.ppaFallbackL)
makeLenses ''Attachment
makeLenses ''ClientPost