{-# LANGUAGE OverloadedStrings #-}

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

import Control.Applicative ((<|>))
import Control.Monad (mzero)
import Data.Aeson (FromJSON (..), Object, ToJSON (..), Value (Object, String), object, (.:), (.:?), (.=))
import Data.Aeson.Types (Pair)
import Data.Text (Text)

data MessageTextType
  = TextType
  | EmoteType
  | NoticeType
  deriving (MessageTextType -> MessageTextType -> Bool
(MessageTextType -> MessageTextType -> Bool)
-> (MessageTextType -> MessageTextType -> Bool)
-> Eq MessageTextType
forall a. (a -> a -> Bool) -> (a -> a -> Bool) -> Eq a
/= :: MessageTextType -> MessageTextType -> Bool
$c/= :: MessageTextType -> MessageTextType -> Bool
== :: MessageTextType -> MessageTextType -> Bool
$c== :: MessageTextType -> MessageTextType -> Bool
Eq, Int -> MessageTextType -> ShowS
[MessageTextType] -> ShowS
MessageTextType -> String
(Int -> MessageTextType -> ShowS)
-> (MessageTextType -> String)
-> ([MessageTextType] -> ShowS)
-> Show MessageTextType
forall a.
(Int -> a -> ShowS) -> (a -> String) -> ([a] -> ShowS) -> Show a
showList :: [MessageTextType] -> ShowS
$cshowList :: [MessageTextType] -> ShowS
show :: MessageTextType -> String
$cshow :: MessageTextType -> String
showsPrec :: Int -> MessageTextType -> ShowS
$cshowsPrec :: Int -> MessageTextType -> ShowS
Show)

instance FromJSON MessageTextType where
  parseJSON :: Value -> Parser MessageTextType
parseJSON (String Text
name) = case Text
name of
    Text
"m.text" -> MessageTextType -> Parser MessageTextType
forall (f :: * -> *) a. Applicative f => a -> f a
pure MessageTextType
TextType
    Text
"m.emote" -> MessageTextType -> Parser MessageTextType
forall (f :: * -> *) a. Applicative f => a -> f a
pure MessageTextType
EmoteType
    Text
"m.notice" -> MessageTextType -> Parser MessageTextType
forall (f :: * -> *) a. Applicative f => a -> f a
pure MessageTextType
NoticeType
    Text
_ -> Parser MessageTextType
forall (m :: * -> *) a. MonadPlus m => m a
mzero
  parseJSON Value
_ = Parser MessageTextType
forall (m :: * -> *) a. MonadPlus m => m a
mzero

instance ToJSON MessageTextType where
  toJSON :: MessageTextType -> Value
toJSON MessageTextType
mt = Text -> Value
String (Text -> Value) -> Text -> Value
forall a b. (a -> b) -> a -> b
$ case MessageTextType
mt of
    MessageTextType
TextType -> Text
"m.text"
    MessageTextType
EmoteType -> Text
"m.emote"
    MessageTextType
NoticeType -> Text
"m.notice"

data MessageText = MessageText
  { MessageText -> Text
mtBody :: Text,
    MessageText -> MessageTextType
mtType :: MessageTextType,
    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)

instance FromJSON MessageText where
  parseJSON :: Value -> Parser MessageText
parseJSON (Object Object
v) =
    Text -> MessageTextType -> Maybe Text -> Maybe Text -> MessageText
MessageText
      (Text
 -> MessageTextType -> Maybe Text -> Maybe Text -> MessageText)
-> Parser Text
-> Parser
     (MessageTextType -> Maybe Text -> Maybe Text -> MessageText)
forall (f :: * -> *) a b. Functor f => (a -> b) -> f a -> f b
<$> Object
v Object -> Key -> Parser Text
forall a. FromJSON a => Object -> Key -> Parser a
.: Key
"body"
        Parser (MessageTextType -> Maybe Text -> Maybe Text -> MessageText)
-> Parser MessageTextType
-> Parser (Maybe Text -> Maybe Text -> MessageText)
forall (f :: * -> *) a b. Applicative f => f (a -> b) -> f a -> f b
<*> Object
v Object -> Key -> Parser MessageTextType
forall a. FromJSON a => Object -> Key -> Parser a
.: Key
"msgtype"
        Parser (Maybe Text -> Maybe Text -> MessageText)
-> Parser (Maybe Text) -> Parser (Maybe Text -> MessageText)
forall (f :: * -> *) a b. Applicative f => f (a -> b) -> f a -> f b
<*> Object
v Object -> Key -> Parser (Maybe Text)
forall a. FromJSON a => Object -> Key -> Parser (Maybe a)
.:? Key
"format"
        Parser (Maybe Text -> MessageText)
-> Parser (Maybe Text) -> Parser MessageText
forall (f :: * -> *) a b. Applicative f => f (a -> b) -> f a -> f b
<*> Object
v Object -> Key -> Parser (Maybe Text)
forall a. FromJSON a => Object -> Key -> Parser (Maybe a)
.:? Key
"formatted_body"
  parseJSON Value
_ = Parser MessageText
forall (m :: * -> *) a. MonadPlus m => m a
mzero

messageTextAttr :: MessageText -> [Pair]
messageTextAttr :: MessageText -> [Pair]
messageTextAttr MessageText
msg =
  [Key
"body" Key -> Text -> Pair
forall kv v. (KeyValue kv, ToJSON v) => Key -> v -> kv
.= MessageText -> Text
mtBody MessageText
msg, Key
"msgtype" Key -> MessageTextType -> Pair
forall kv v. (KeyValue kv, ToJSON v) => Key -> v -> kv
.= MessageText -> MessageTextType
mtType 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 :: Key -> Maybe v -> [a]
omitNull Key
k Maybe v
vM = [a] -> (v -> [a]) -> Maybe v -> [a]
forall b a. b -> (a -> b) -> Maybe a -> b
maybe [] (\v
v -> [Key
k Key -> v -> a
forall kv v. (KeyValue kv, ToJSON v) => Key -> v -> kv
.= v
v]) Maybe v
vM
    format :: [Pair]
format = Key -> Maybe Text -> [Pair]
forall a v. (KeyValue a, ToJSON v) => Key -> Maybe v -> [a]
omitNull Key
"format" (Maybe Text -> [Pair]) -> Maybe Text -> [Pair]
forall a b. (a -> b) -> a -> b
$ MessageText -> Maybe Text
mtFormat MessageText
msg
    formattedBody :: [Pair]
formattedBody = Key -> Maybe Text -> [Pair]
forall a v. (KeyValue a, ToJSON v) => Key -> Maybe v -> [a]
omitNull Key
"formatted_body" (Maybe Text -> [Pair]) -> Maybe Text -> [Pair]
forall a b. (a -> b) -> a -> b
$ MessageText -> Maybe Text
mtFormattedBody MessageText
msg

instance ToJSON MessageText where
  toJSON :: MessageText -> Value
toJSON = [Pair] -> Value
object ([Pair] -> Value)
-> (MessageText -> [Pair]) -> MessageText -> Value
forall b c a. (b -> c) -> (a -> b) -> a -> c
. MessageText -> [Pair]
messageTextAttr

newtype RoomMessage
  = RoomMessageText 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)

roomMessageAttr :: RoomMessage -> [Pair]
roomMessageAttr :: RoomMessage -> [Pair]
roomMessageAttr RoomMessage
rm = case RoomMessage
rm of
  RoomMessageText MessageText
mt -> MessageText -> [Pair]
messageTextAttr MessageText
mt

instance ToJSON RoomMessage where
  toJSON :: RoomMessage -> Value
toJSON RoomMessage
msg = case RoomMessage
msg of
    RoomMessageText MessageText
mt -> MessageText -> Value
forall a. ToJSON a => a -> Value
toJSON MessageText
mt

instance FromJSON RoomMessage where
  parseJSON :: Value -> Parser RoomMessage
parseJSON Value
x = MessageText -> RoomMessage
RoomMessageText (MessageText -> RoomMessage)
-> Parser MessageText -> Parser RoomMessage
forall (f :: * -> *) a b. Functor f => (a -> b) -> f a -> f b
<$> Value -> Parser MessageText
forall a. FromJSON a => Value -> Parser a
parseJSON Value
x

data RelatedMessage = RelatedMessage
  { RelatedMessage -> RoomMessage
rmMessage :: RoomMessage,
    RelatedMessage -> EventID
rmRelatedTo :: EventID
  }
  deriving (Int -> RelatedMessage -> ShowS
[RelatedMessage] -> ShowS
RelatedMessage -> String
(Int -> RelatedMessage -> ShowS)
-> (RelatedMessage -> String)
-> ([RelatedMessage] -> ShowS)
-> Show RelatedMessage
forall a.
(Int -> a -> ShowS) -> (a -> String) -> ([a] -> ShowS) -> Show a
showList :: [RelatedMessage] -> ShowS
$cshowList :: [RelatedMessage] -> ShowS
show :: RelatedMessage -> String
$cshow :: RelatedMessage -> String
showsPrec :: Int -> RelatedMessage -> ShowS
$cshowsPrec :: Int -> RelatedMessage -> ShowS
Show, RelatedMessage -> RelatedMessage -> Bool
(RelatedMessage -> RelatedMessage -> Bool)
-> (RelatedMessage -> RelatedMessage -> Bool) -> Eq RelatedMessage
forall a. (a -> a -> Bool) -> (a -> a -> Bool) -> Eq a
/= :: RelatedMessage -> RelatedMessage -> Bool
$c/= :: RelatedMessage -> RelatedMessage -> Bool
== :: RelatedMessage -> RelatedMessage -> Bool
$c== :: RelatedMessage -> RelatedMessage -> Bool
Eq)

data Event
  = EventRoomMessage RoomMessage
  | -- | A reply defined by the parent event id and the reply message
    EventRoomReply EventID RoomMessage
  | -- | An edit defined by the original message and the new message
    EventRoomEdit (EventID, RoomMessage) RoomMessage
  | EventUnknown Object
  deriving (Event -> Event -> Bool
(Event -> Event -> Bool) -> (Event -> Event -> Bool) -> Eq Event
forall a. (a -> a -> Bool) -> (a -> a -> Bool) -> Eq a
/= :: Event -> Event -> Bool
$c/= :: Event -> Event -> Bool
== :: Event -> Event -> Bool
$c== :: Event -> Event -> Bool
Eq, Int -> Event -> ShowS
[Event] -> ShowS
Event -> String
(Int -> Event -> ShowS)
-> (Event -> String) -> ([Event] -> ShowS) -> Show Event
forall a.
(Int -> a -> ShowS) -> (a -> String) -> ([a] -> ShowS) -> Show a
showList :: [Event] -> ShowS
$cshowList :: [Event] -> ShowS
show :: Event -> String
$cshow :: Event -> String
showsPrec :: Int -> Event -> ShowS
$cshowsPrec :: Int -> Event -> ShowS
Show)

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
    EventRoomReply EventID
eventID RoomMessage
msg ->
      let replyAttr :: [Pair]
replyAttr =
            [ Key
"m.relates_to"
                Key -> Value -> Pair
forall kv v. (KeyValue kv, ToJSON v) => Key -> v -> kv
.= [Pair] -> Value
object
                  [ Key
"m.in_reply_to" Key -> Value -> Pair
forall kv v. (KeyValue kv, ToJSON v) => Key -> v -> kv
.= EventID -> Value
forall a. ToJSON a => a -> Value
toJSON EventID
eventID
                  ]
            ]
       in [Pair] -> Value
object ([Pair] -> Value) -> [Pair] -> Value
forall a b. (a -> b) -> a -> b
$ [Pair]
replyAttr [Pair] -> [Pair] -> [Pair]
forall a. Semigroup a => a -> a -> a
<> RoomMessage -> [Pair]
roomMessageAttr RoomMessage
msg
    EventRoomEdit (EventID Text
eventID, RoomMessage
msg) RoomMessage
newMsg ->
      let editAttr :: [Pair]
editAttr =
            [ Key
"m.relates_to"
                Key -> Value -> Pair
forall kv v. (KeyValue kv, ToJSON v) => Key -> v -> kv
.= [Pair] -> Value
object
                  [ Key
"rel_type" Key -> Text -> Pair
forall kv v. (KeyValue kv, ToJSON v) => Key -> v -> kv
.= (Text
"m.replace" :: Text),
                    Key
"event_id" Key -> Text -> Pair
forall kv v. (KeyValue kv, ToJSON v) => Key -> v -> kv
.= Text
eventID
                  ],
              Key
"m.new_content" Key -> Value -> Pair
forall kv v. (KeyValue kv, ToJSON v) => Key -> v -> kv
.= [Pair] -> Value
object (RoomMessage -> [Pair]
roomMessageAttr RoomMessage
newMsg)
            ]
       in [Pair] -> Value
object ([Pair] -> Value) -> [Pair] -> Value
forall a b. (a -> b) -> a -> b
$ [Pair]
editAttr [Pair] -> [Pair] -> [Pair]
forall a. Semigroup a => a -> a -> a
<> RoomMessage -> [Pair]
roomMessageAttr RoomMessage
msg
    EventUnknown Object
v -> Object -> Value
Object Object
v

instance FromJSON Event where
  parseJSON :: Value -> Parser Event
parseJSON (Object Object
content) =
    Parser Event
parseRelated Parser Event -> Parser Event -> Parser Event
forall (f :: * -> *) a. Alternative f => f a -> f a -> f a
<|> Parser Event
parseMessage Parser Event -> Parser Event -> Parser Event
forall (f :: * -> *) a. Alternative f => f a -> f a -> f a
<|> Event -> Parser Event
forall (f :: * -> *) a. Applicative f => a -> f a
pure (Object -> Event
EventUnknown Object
content)
    where
      parseMessage :: Parser Event
parseMessage = RoomMessage -> Event
EventRoomMessage (RoomMessage -> Event) -> Parser RoomMessage -> Parser Event
forall (f :: * -> *) a b. Functor f => (a -> b) -> f a -> f b
<$> Value -> Parser RoomMessage
forall a. FromJSON a => Value -> Parser a
parseJSON (Object -> Value
Object Object
content)
      parseRelated :: Parser Event
parseRelated = do
        Value
relateM <- Object
content Object -> Key -> Parser Value
forall a. FromJSON a => Object -> Key -> Parser a
.: Key
"m.relates_to"
        case Value
relateM of
          Object Object
relate -> Object -> Parser Event
parseReply Object
relate Parser Event -> Parser Event -> Parser Event
forall (f :: * -> *) a. Alternative f => f a -> f a -> f a
<|> Object -> Parser Event
parseReplace Object
relate
          Value
_ -> Parser Event
forall (m :: * -> *) a. MonadPlus m => m a
mzero
      parseReply :: Object -> Parser Event
parseReply Object
relate =
        EventID -> RoomMessage -> Event
EventRoomReply (EventID -> RoomMessage -> Event)
-> Parser EventID -> Parser (RoomMessage -> Event)
forall (f :: * -> *) a b. Functor f => (a -> b) -> f a -> f b
<$> Object
relate Object -> Key -> Parser EventID
forall a. FromJSON a => Object -> Key -> Parser a
.: Key
"m.in_reply_to" Parser (RoomMessage -> Event) -> Parser RoomMessage -> Parser Event
forall (f :: * -> *) a b. Applicative f => f (a -> b) -> f a -> f b
<*> Value -> Parser RoomMessage
forall a. FromJSON a => Value -> Parser a
parseJSON (Object -> Value
Object Object
content)
      parseReplace :: Object -> Parser Event
parseReplace Object
relate = do
        Text
rel_type <- Object
relate Object -> Key -> Parser Text
forall a. FromJSON a => Object -> Key -> Parser a
.: Key
"rel_type"
        if Text
rel_type Text -> Text -> Bool
forall a. Eq a => a -> a -> Bool
== (Text
"m.replace" :: Text)
          then do
            EventID
ev <- Text -> EventID
EventID (Text -> EventID) -> Parser Text -> Parser EventID
forall (f :: * -> *) a b. Functor f => (a -> b) -> f a -> f b
<$> Object
relate Object -> Key -> Parser Text
forall a. FromJSON a => Object -> Key -> Parser a
.: Key
"event_id"
            RoomMessage
msg <- Value -> Parser RoomMessage
forall a. FromJSON a => Value -> Parser a
parseJSON (Object -> Value
Object Object
content)
            (EventID, RoomMessage) -> RoomMessage -> Event
EventRoomEdit (EventID
ev, RoomMessage
msg) (RoomMessage -> Event) -> Parser RoomMessage -> Parser Event
forall (f :: * -> *) a b. Functor f => (a -> b) -> f a -> f b
<$> Object
content Object -> Key -> Parser RoomMessage
forall a. FromJSON a => Object -> Key -> Parser a
.: Key
"m.new_content"
          else Parser Event
forall (m :: * -> *) a. MonadPlus m => m a
mzero
  parseJSON Value
_ = Parser Event
forall (m :: * -> *) a. MonadPlus m => m a
mzero

eventType :: Event -> Text
eventType :: Event -> Text
eventType Event
event = case Event
event of
  EventRoomMessage RoomMessage
_ -> Text
"m.room.message"
  EventRoomReply EventID
_ RoomMessage
_ -> Text
"m.room.message"
  EventRoomEdit (EventID, RoomMessage)
_ RoomMessage
_ -> Text
"m.room.message"
  EventUnknown Object
_ -> String -> Text
forall a. HasCallStack => String -> a
error (String -> Text) -> String -> Text
forall a b. (a -> b) -> a -> b
$ String
"Event is not implemented: " String -> ShowS
forall a. Semigroup a => a -> a -> a
<> Event -> String
forall a. Show a => a -> String
show Event
event

newtype EventID = EventID {EventID -> Text
unEventID :: 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, EventID -> EventID -> Bool
(EventID -> EventID -> Bool)
-> (EventID -> EventID -> Bool) -> Eq EventID
forall a. (a -> a -> Bool) -> (a -> a -> Bool) -> Eq a
/= :: EventID -> EventID -> Bool
$c/= :: EventID -> EventID -> Bool
== :: EventID -> EventID -> Bool
$c== :: EventID -> EventID -> Bool
Eq, Eq EventID
Eq EventID
-> (EventID -> EventID -> Ordering)
-> (EventID -> EventID -> Bool)
-> (EventID -> EventID -> Bool)
-> (EventID -> EventID -> Bool)
-> (EventID -> EventID -> Bool)
-> (EventID -> EventID -> EventID)
-> (EventID -> EventID -> EventID)
-> Ord EventID
EventID -> EventID -> Bool
EventID -> EventID -> Ordering
EventID -> EventID -> EventID
forall a.
Eq a
-> (a -> a -> Ordering)
-> (a -> a -> Bool)
-> (a -> a -> Bool)
-> (a -> a -> Bool)
-> (a -> a -> Bool)
-> (a -> a -> a)
-> (a -> a -> a)
-> Ord a
min :: EventID -> EventID -> EventID
$cmin :: EventID -> EventID -> EventID
max :: EventID -> EventID -> EventID
$cmax :: EventID -> EventID -> EventID
>= :: EventID -> EventID -> Bool
$c>= :: EventID -> EventID -> Bool
> :: EventID -> EventID -> Bool
$c> :: EventID -> EventID -> Bool
<= :: EventID -> EventID -> Bool
$c<= :: EventID -> EventID -> Bool
< :: EventID -> EventID -> Bool
$c< :: EventID -> EventID -> Bool
compare :: EventID -> EventID -> Ordering
$ccompare :: EventID -> EventID -> Ordering
$cp1Ord :: Eq EventID
Ord)

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 -> Key -> Parser Text
forall a. FromJSON a => Object -> Key -> Parser a
.: Key
"event_id"
  parseJSON Value
_ = Parser EventID
forall (m :: * -> *) a. MonadPlus m => m a
mzero

instance ToJSON EventID where
  toJSON :: EventID -> Value
toJSON (EventID Text
v) = [Pair] -> Value
object [Key
"event_id" Key -> Text -> Pair
forall kv v. (KeyValue kv, ToJSON v) => Key -> v -> kv
.= Text
v]