{-# 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 ( Blocks(..), Block(Blockquote), parseMarkdown
                                           , TeamBaseURL
                                           )


-- * 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
(Int -> ClientMessage -> ShowS)
-> (ClientMessage -> String)
-> ([ClientMessage] -> ShowS)
-> Show ClientMessage
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 :: ClientMessageType -> Text -> m ClientMessage
newClientMessage ClientMessageType
ty Text
msg = do
  UTCTime
now <- IO UTCTime -> m UTCTime
forall (m :: * -> *) a. MonadIO m => IO a -> m a
liftIO IO UTCTime
getCurrentTime
  ClientMessage -> m ClientMessage
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
(Int -> ClientMessageType -> ShowS)
-> (ClientMessageType -> String)
-> ([ClientMessageType] -> ShowS)
-> Show ClientMessageType
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
(ClientMessageType -> ClientMessageType -> Bool)
-> (ClientMessageType -> ClientMessageType -> Bool)
-> Eq ClientMessageType
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
(Int -> ClientPost -> ShowS)
-> (ClientPost -> String)
-> ([ClientPost] -> ShowS)
-> Show ClientPost
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
(Attachment -> Attachment -> Bool)
-> (Attachment -> Attachment -> Bool) -> Eq Attachment
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
(Int -> Attachment -> ShowS)
-> (Attachment -> String)
-> ([Attachment] -> ShowS)
-> Show Attachment
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
(ClientPostType -> ClientPostType -> Bool)
-> (ClientPostType -> ClientPostType -> Bool) -> Eq ClientPostType
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
(Int -> ClientPostType -> ShowS)
-> (ClientPostType -> String)
-> ([ClientPostType] -> ShowS)
-> Show ClientPostType
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 PostType -> PostType -> Bool
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 =
    [Bool] -> Bool
forall (t :: * -> *). Foldable t => t Bool -> Bool
and [ Post
pPost -> Getting (Maybe Text) Post (Maybe Text) -> Maybe Text
forall s a. s -> Getting a s a -> a
^.(PostProps -> Const (Maybe Text) PostProps)
-> Post -> Const (Maybe Text) Post
Lens' Post PostProps
postPropsL((PostProps -> Const (Maybe Text) PostProps)
 -> Post -> Const (Maybe Text) Post)
-> ((Maybe Text -> Const (Maybe Text) (Maybe Text))
    -> PostProps -> Const (Maybe Text) PostProps)
-> Getting (Maybe Text) Post (Maybe Text)
forall b c a. (b -> c) -> (a -> b) -> a -> c
.(Maybe Text -> Const (Maybe Text) (Maybe Text))
-> PostProps -> Const (Maybe Text) PostProps
Lens' PostProps (Maybe Text)
postPropsOverrideIconUrlL Maybe Text -> Maybe Text -> Bool
forall a. Eq a => a -> a -> Bool
== Text -> Maybe Text
forall a. a -> Maybe a
Just (Text
""::Text)
        , (Text
"*" Text -> Text -> Bool
`T.isPrefixOf` (UserText -> Text
sanitizeUserText (UserText -> Text) -> UserText -> Text
forall a b. (a -> b) -> a -> b
$ Post -> UserText
postMessage Post
p))
        , (Text
"*" Text -> Text -> Bool
`T.isSuffixOf` (UserText -> Text
sanitizeUserText (UserText -> Text) -> UserText -> Text
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
pPost -> Getting PostType Post PostType -> PostType
forall s a. s -> Getting a s a -> a
^.Getting PostType Post PostType
Lens' Post PostType
postTypeL PostType -> PostType -> Bool
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
pPost -> Getting PostType Post PostType -> PostType
forall s a. s -> Getting a s a -> a
^.Getting PostType Post PostType
Lens' Post PostType
postTypeL PostType -> PostType -> Bool
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 (Text -> Text) -> Text -> Text
forall a b. (a -> b) -> a -> b
$ Text -> Text
T.tail Text
t
                  else Text
t
unEmote ClientPostType
_ Text
t = Text
t

-- | Convert a Mattermost 'Post' to a 'ClientPost', passing in a
--   'ParentId' if it has a known one.
toClientPost :: Maybe TeamBaseURL -> Post -> Maybe PostId -> ClientPost
toClientPost :: Maybe TeamBaseURL -> Post -> Maybe PostId -> ClientPost
toClientPost Maybe TeamBaseURL
baseUrl Post
p Maybe PostId
parentId =
  let src :: Text
src = ClientPostType -> Text -> Text
unEmote (Post -> ClientPostType
postClientPostType Post
p) (Text -> Text) -> Text -> Text
forall a b. (a -> b) -> a -> b
$ UserText -> Text
sanitizeUserText (UserText -> Text) -> UserText -> Text
forall a b. (a -> b) -> a -> b
$ Post -> UserText
postMessage Post
p
  in ClientPost :: Blocks
-> Text
-> Maybe UserId
-> Maybe Text
-> ServerTime
-> ClientPostType
-> Bool
-> Bool
-> Seq Attachment
-> Maybe PostId
-> PostId
-> ChannelId
-> Map Text (Set UserId)
-> Post
-> Bool
-> Bool
-> ClientPost
ClientPost { _cpText :: Blocks
_cpText          = Maybe TeamBaseURL -> Text -> Blocks
parseMarkdown Maybe TeamBaseURL
baseUrl Text
src Blocks -> Blocks -> Blocks
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
pPost -> Getting (Maybe Text) Post (Maybe Text) -> Maybe Text
forall s a. s -> Getting a s a -> a
^.(PostProps -> Const (Maybe Text) PostProps)
-> Post -> Const (Maybe Text) Post
Lens' Post PostProps
postPropsL((PostProps -> Const (Maybe Text) PostProps)
 -> Post -> Const (Maybe Text) Post)
-> ((Maybe Text -> Const (Maybe Text) (Maybe Text))
    -> PostProps -> Const (Maybe Text) PostProps)
-> Getting (Maybe Text) Post (Maybe Text)
forall b c a. (b -> c) -> (a -> b) -> a -> c
.(Maybe Text -> Const (Maybe Text) (Maybe Text))
-> PostProps -> Const (Maybe Text) PostProps
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        = Bool -> Maybe Bool -> Bool
forall a. a -> Maybe a -> a
fromMaybe Bool
False (Maybe Bool -> Bool) -> Maybe Bool -> Bool
forall a b. (a -> b) -> a -> b
$ Post -> Maybe Bool
postPinned Post
p
                , _cpAttachments :: Seq Attachment
_cpAttachments   = Seq Attachment
forall a. Seq a
Seq.empty
                , _cpInReplyToPost :: Maybe PostId
_cpInReplyToPost = Maybe PostId
parentId
                , _cpPostId :: PostId
_cpPostId        = Post
pPost -> Getting PostId Post PostId -> PostId
forall s a. s -> Getting a s a -> a
^.Getting PostId Post PostId
Lens' Post PostId
postIdL
                , _cpChannelId :: ChannelId
_cpChannelId     = Post
pPost -> Getting ChannelId Post ChannelId -> ChannelId
forall s a. s -> Getting a s a -> a
^.Getting ChannelId Post ChannelId
Lens' Post ChannelId
postChannelIdL
                , _cpReactions :: Map Text (Set UserId)
_cpReactions     = Map Text (Set UserId)
forall k a. Map k a
Map.empty
                , _cpOriginalPost :: Post
_cpOriginalPost  = Post
p
                , _cpFromWebhook :: Bool
_cpFromWebhook   = Bool -> Maybe Bool -> Bool
forall a. a -> Maybe a -> a
fromMaybe Bool
False (Maybe Bool -> Bool) -> Maybe Bool -> Bool
forall a b. (a -> b) -> a -> b
$ Post
pPost -> Getting (Maybe Bool) Post (Maybe Bool) -> Maybe Bool
forall s a. s -> Getting a s a -> a
^.(PostProps -> Const (Maybe Bool) PostProps)
-> Post -> Const (Maybe Bool) Post
Lens' Post PostProps
postPropsL((PostProps -> Const (Maybe Bool) PostProps)
 -> Post -> Const (Maybe Bool) Post)
-> ((Maybe Bool -> Const (Maybe Bool) (Maybe Bool))
    -> PostProps -> Const (Maybe Bool) PostProps)
-> Getting (Maybe Bool) Post (Maybe Bool)
forall b c a. (b -> c) -> (a -> b) -> a -> c
.(Maybe Bool -> Const (Maybe Bool) (Maybe Bool))
-> PostProps -> Const (Maybe Bool) PostProps
Lens' PostProps (Maybe Bool)
postPropsFromWebhookL
                }

-- | 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
pPost
-> Getting
     (Maybe (Seq PostPropAttachment))
     Post
     (Maybe (Seq PostPropAttachment))
-> Maybe (Seq PostPropAttachment)
forall s a. s -> Getting a s a -> a
^.(PostProps -> Const (Maybe (Seq PostPropAttachment)) PostProps)
-> Post -> Const (Maybe (Seq PostPropAttachment)) Post
Lens' Post PostProps
postPropsL((PostProps -> Const (Maybe (Seq PostPropAttachment)) PostProps)
 -> Post -> Const (Maybe (Seq PostPropAttachment)) Post)
-> ((Maybe (Seq PostPropAttachment)
     -> Const
          (Maybe (Seq PostPropAttachment)) (Maybe (Seq PostPropAttachment)))
    -> PostProps -> Const (Maybe (Seq PostPropAttachment)) PostProps)
-> Getting
     (Maybe (Seq PostPropAttachment))
     Post
     (Maybe (Seq PostPropAttachment))
forall b c a. (b -> c) -> (a -> b) -> a -> c
.(Maybe (Seq PostPropAttachment)
 -> Const
      (Maybe (Seq PostPropAttachment)) (Maybe (Seq PostPropAttachment)))
-> PostProps -> Const (Maybe (Seq PostPropAttachment)) PostProps
Lens' PostProps (Maybe (Seq PostPropAttachment))
postPropsAttachmentsL of
    Maybe (Seq PostPropAttachment)
Nothing -> Blocks
forall a. Monoid a => a
mempty
    Just Seq PostPropAttachment
attachments ->
      Seq Block -> Blocks
Blocks (Seq Block -> Blocks) -> Seq Block -> Blocks
forall a b. (a -> b) -> a -> b
$ (PostPropAttachment -> Block)
-> Seq PostPropAttachment -> Seq Block
forall (f :: * -> *) a b. Functor f => (a -> b) -> f a -> f b
fmap (Blocks -> Block
Blockquote (Blocks -> Block)
-> (PostPropAttachment -> Blocks) -> PostPropAttachment -> Block
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 Maybe TeamBaseURL
forall a. Maybe a
Nothing (PostPropAttachment
attPostPropAttachment -> Getting Text PostPropAttachment Text -> Text
forall s a. s -> Getting a s a -> a
^.Getting Text PostPropAttachment Text
Lens' PostPropAttachment Text
ppaTextL) Blocks -> Blocks -> Blocks
forall a. Semigroup a => a -> a -> a
<>
                     Maybe TeamBaseURL -> Text -> Blocks
parseMarkdown Maybe TeamBaseURL
forall a. Maybe a
Nothing (PostPropAttachment
attPostPropAttachment -> Getting Text PostPropAttachment Text -> Text
forall s a. s -> Getting a s a -> a
^.Getting Text PostPropAttachment Text
Lens' PostPropAttachment Text
ppaFallbackL)

-- ** 'ClientPost' Lenses

makeLenses ''Attachment
makeLenses ''ClientPost