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

  , ClientMessageType(..)

  , Attachment
  , mkAttachment
  , attachmentName
  , attachmentFileId
  , attachmentURL

  , ClientPostType(..)

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

  , unEmote

  , postIsLeave
  , postIsJoin
  , postIsTopicChange
  , postIsEmote

  , getBlocks
  )
where

import           Prelude ()
import           Prelude.MH

import           Cheapskate ( Blocks )
import qualified Cheapskate as C
import qualified Data.Map.Strict as Map
import qualified Data.Sequence as Seq
import qualified Data.Text as T
import           Data.Time.Clock ( getCurrentTime )
import           Lens.Micro.Platform ( makeLenses )

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

import           Types.Common


-- * Client Messages

-- | A 'ClientMessage' is a message given to us by our client,
--   like help text or an error message.
data ClientMessage = ClientMessage
  { _cmText :: Text
  , _cmDate :: ServerTime
  , _cmType :: ClientMessageType
  } deriving (Eq, 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 ty msg = do
  now <- liftIO getCurrentTime
  return (ClientMessage msg (ServerTime now) ty)

-- | We format 'ClientMessage' values differently depending on
--   their 'ClientMessageType'
data ClientMessageType =
    Informative
    | Error
    | DateTransition
    | NewMessagesTransition
    | UnknownGap  -- ^ marks region where server may have messages unknown locally
    deriving (Eq, Show)

-- ** '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
  { _cpText          :: Blocks
  , _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 Int
  , _cpOriginalPost  :: Post
  } deriving (Show)

-- | An attachment has a very long URL associated, as well as
--   an actual file URL
data Attachment = Attachment
  { _attachmentName   :: Text
  , _attachmentURL    :: Text
  , _attachmentFileId :: FileId
  } deriving (Eq, Show)

mkAttachment :: Text -> Text -> FileId -> Attachment
mkAttachment = 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 (Eq, Show)

-- ** Creating 'ClientPost' Values

-- | Parse text as Markdown and extract the AST
getBlocks :: Text -> Blocks
getBlocks s = bs where C.Doc _ bs = C.markdown C.def s

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

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

-- | Find out whether a 'Post' is from a @/me@ command
postIsEmote :: Post -> Bool
postIsEmote p =
    and [ p^.postPropsL.postPropsOverrideIconUrlL == Just (""::Text)
        , ("*" `T.isPrefixOf` (sanitizeUserText $ postMessage p))
        , ("*" `T.isSuffixOf` (sanitizeUserText $ postMessage p))
        ]

-- | Find out whether a 'Post' is a user joining a channel
postIsJoin :: Post -> Bool
postIsJoin p =
  p^.postTypeL == PostTypeJoinChannel

-- | Find out whether a 'Post' is a user leaving a channel
postIsLeave :: Post -> Bool
postIsLeave p =
  p^.postTypeL == PostTypeLeaveChannel

-- | Undo the automatic formatting of posts generated by @/me@-commands
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

-- | Convert a Mattermost 'Post' to a 'ClientPost', passing in a
--   'ParentId' if it has a known one.
toClientPost :: Post -> Maybe PostId -> ClientPost
toClientPost p parentId =
  let src = unEmote (postClientPostType p) $ sanitizeUserText $ postMessage p
  in ClientPost { _cpText          = getBlocks src <> getAttachmentText p
                , _cpMarkdownSource = src
                , _cpUser          = postUserId p
                , _cpUserOverride  = p^.postPropsL.postPropsOverrideUsernameL
                , _cpDate          = postCreateAt p
                , _cpType          = postClientPostType p
                , _cpPending       = False
                , _cpDeleted       = False
                , _cpAttachments   = Seq.empty
                , _cpInReplyToPost = parentId
                , _cpPostId        = p^.postIdL
                , _cpChannelId     = p^.postChannelIdL
                , _cpReactions     = Map.empty
                , _cpOriginalPost  = p
                }

-- | Right now, instead of treating 'attachment' properties specially, we're
--   just going to roll them directly into the message text
getAttachmentText :: Post -> Blocks
getAttachmentText p =
  case p^.postPropsL.postPropsAttachmentsL of
    Nothing -> Seq.empty
    Just attachments ->
      fmap (C.Blockquote . render) attachments
  where render att = getBlocks (att^.ppaTextL) <> getBlocks (att^.ppaFallbackL)

-- ** 'ClientPost' Lenses

makeLenses ''Attachment
makeLenses ''ClientPost