{-# 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
)
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)
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)
data ClientMessageType =
Informative
| Error
| DateTransition
| NewMessagesTransition
| UnknownGapBefore
| UnknownGapAfter
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)
makeLenses ''ClientMessage
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)
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
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)
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
postIsTopicChange :: Post -> Bool
postIsTopicChange :: Post -> Bool
postIsTopicChange Post
p = Post -> PostType
postType Post
p forall a. Eq a => a -> a -> Bool
== PostType
PostTypeHeaderChange
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))
]
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
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
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
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
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)
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
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]
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]
makeLenses ''Attachment
makeLenses ''ClientPost