{-# LANGUAGE OverloadedStrings #-}

-- | Matrix event data type
module Network.Matrix.Events
  ( MessageText (..),
    RoomMessage (..),
    Event (..),
    EventID (..),
    eventType,
  )
where

import Control.Monad (mzero)
import Data.Aeson (FromJSON (..), ToJSON (..), Value (Object), object, (.:), (.=))
import Data.Aeson.Types (Pair)
import Data.Text (Text)

data MessageText = MessageText
  { MessageText -> Text
mtBody :: Text,
    MessageText -> Maybe Text
mtFormat :: Maybe Text,
    MessageText -> Maybe Text
mtFormattedBody :: Maybe Text
  }
  deriving (Int -> MessageText -> ShowS
[MessageText] -> ShowS
MessageText -> String
(Int -> MessageText -> ShowS)
-> (MessageText -> String)
-> ([MessageText] -> ShowS)
-> Show MessageText
forall a.
(Int -> a -> ShowS) -> (a -> String) -> ([a] -> ShowS) -> Show a
showList :: [MessageText] -> ShowS
$cshowList :: [MessageText] -> ShowS
show :: MessageText -> String
$cshow :: MessageText -> String
showsPrec :: Int -> MessageText -> ShowS
$cshowsPrec :: Int -> MessageText -> ShowS
Show, MessageText -> MessageText -> Bool
(MessageText -> MessageText -> Bool)
-> (MessageText -> MessageText -> Bool) -> Eq MessageText
forall a. (a -> a -> Bool) -> (a -> a -> Bool) -> Eq a
/= :: MessageText -> MessageText -> Bool
$c/= :: MessageText -> MessageText -> Bool
== :: MessageText -> MessageText -> Bool
$c== :: MessageText -> MessageText -> Bool
Eq)

messageTextAttr :: MessageText -> [Pair]
messageTextAttr :: MessageText -> [Pair]
messageTextAttr MessageText
msg =
  [Text
"body" Text -> Text -> Pair
forall kv v. (KeyValue kv, ToJSON v) => Text -> v -> kv
.= MessageText -> Text
mtBody MessageText
msg] [Pair] -> [Pair] -> [Pair]
forall a. Semigroup a => a -> a -> a
<> [Pair]
format [Pair] -> [Pair] -> [Pair]
forall a. Semigroup a => a -> a -> a
<> [Pair]
formattedBody
  where
    omitNull :: Text -> Maybe v -> [a]
omitNull Text
k Maybe v
vM = [a] -> (v -> [a]) -> Maybe v -> [a]
forall b a. b -> (a -> b) -> Maybe a -> b
maybe [] (\v
v -> [Text
k Text -> v -> a
forall kv v. (KeyValue kv, ToJSON v) => Text -> v -> kv
.= v
v]) Maybe v
vM
    format :: [Pair]
format = Text -> Maybe Text -> [Pair]
forall a v. (KeyValue a, ToJSON v) => Text -> Maybe v -> [a]
omitNull Text
"format" (Maybe Text -> [Pair]) -> Maybe Text -> [Pair]
forall a b. (a -> b) -> a -> b
$ MessageText -> Maybe Text
mtFormat MessageText
msg
    formattedBody :: [Pair]
formattedBody = Text -> Maybe Text -> [Pair]
forall a v. (KeyValue a, ToJSON v) => Text -> Maybe v -> [a]
omitNull Text
"formatted_body" (Maybe Text -> [Pair]) -> Maybe Text -> [Pair]
forall a b. (a -> b) -> a -> b
$ MessageText -> Maybe Text
mtFormattedBody MessageText
msg

data RoomMessage
  = RoomMessageText MessageText
  | RoomMessageEmote MessageText
  | RoomMessageNotice MessageText
  deriving (Int -> RoomMessage -> ShowS
[RoomMessage] -> ShowS
RoomMessage -> String
(Int -> RoomMessage -> ShowS)
-> (RoomMessage -> String)
-> ([RoomMessage] -> ShowS)
-> Show RoomMessage
forall a.
(Int -> a -> ShowS) -> (a -> String) -> ([a] -> ShowS) -> Show a
showList :: [RoomMessage] -> ShowS
$cshowList :: [RoomMessage] -> ShowS
show :: RoomMessage -> String
$cshow :: RoomMessage -> String
showsPrec :: Int -> RoomMessage -> ShowS
$cshowsPrec :: Int -> RoomMessage -> ShowS
Show, RoomMessage -> RoomMessage -> Bool
(RoomMessage -> RoomMessage -> Bool)
-> (RoomMessage -> RoomMessage -> Bool) -> Eq RoomMessage
forall a. (a -> a -> Bool) -> (a -> a -> Bool) -> Eq a
/= :: RoomMessage -> RoomMessage -> Bool
$c/= :: RoomMessage -> RoomMessage -> Bool
== :: RoomMessage -> RoomMessage -> Bool
$c== :: RoomMessage -> RoomMessage -> Bool
Eq)

roomMessageType :: RoomMessage -> Text
roomMessageType :: RoomMessage -> Text
roomMessageType RoomMessage
roomMessage = case RoomMessage
roomMessage of
  RoomMessageText MessageText
_ -> Text
"m.text"
  RoomMessageEmote MessageText
_ -> Text
"m.emote"
  RoomMessageNotice MessageText
_ -> Text
"m.notice"

instance ToJSON RoomMessage where
  toJSON :: RoomMessage -> Value
toJSON RoomMessage
msg =
    let msgtype :: Text
msgtype = RoomMessage -> Text
roomMessageType RoomMessage
msg
        attr :: [Pair]
attr = case RoomMessage
msg of
          RoomMessageText MessageText
mt -> MessageText -> [Pair]
messageTextAttr MessageText
mt
          RoomMessageEmote MessageText
mt -> MessageText -> [Pair]
messageTextAttr MessageText
mt
          RoomMessageNotice MessageText
mt -> MessageText -> [Pair]
messageTextAttr MessageText
mt
     in [Pair] -> Value
object ([Text
"msgtype" Text -> Text -> Pair
forall kv v. (KeyValue kv, ToJSON v) => Text -> v -> kv
.= Text
msgtype] [Pair] -> [Pair] -> [Pair]
forall a. Semigroup a => a -> a -> a
<> [Pair]
attr)

newtype Event = EventRoomMessage RoomMessage

instance ToJSON Event where
  toJSON :: Event -> Value
toJSON Event
event = case Event
event of
    EventRoomMessage RoomMessage
msg -> RoomMessage -> Value
forall a. ToJSON a => a -> Value
toJSON RoomMessage
msg

eventType :: Event -> Text
eventType :: Event -> Text
eventType Event
event = case Event
event of
  EventRoomMessage RoomMessage
_ -> Text
"m.room.message"

newtype EventID = EventID Text deriving (Int -> EventID -> ShowS
[EventID] -> ShowS
EventID -> String
(Int -> EventID -> ShowS)
-> (EventID -> String) -> ([EventID] -> ShowS) -> Show EventID
forall a.
(Int -> a -> ShowS) -> (a -> String) -> ([a] -> ShowS) -> Show a
showList :: [EventID] -> ShowS
$cshowList :: [EventID] -> ShowS
show :: EventID -> String
$cshow :: EventID -> String
showsPrec :: Int -> EventID -> ShowS
$cshowsPrec :: Int -> EventID -> ShowS
Show)

instance FromJSON EventID where
  parseJSON :: Value -> Parser EventID
parseJSON (Object Object
v) = Text -> EventID
EventID (Text -> EventID) -> Parser Text -> Parser EventID
forall (f :: * -> *) a b. Functor f => (a -> b) -> f a -> f b
<$> Object
v Object -> Text -> Parser Text
forall a. FromJSON a => Object -> Text -> Parser a
.: Text
"event_id"
  parseJSON Value
_ = Parser EventID
forall (m :: * -> *) a. MonadPlus m => m a
mzero