{-# 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
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 -> [Char]
forall a.
(Int -> a -> ShowS) -> (a -> [Char]) -> ([a] -> ShowS) -> Show a
showList :: [MessageTextType] -> ShowS
$cshowList :: [MessageTextType] -> ShowS
show :: MessageTextType -> [Char]
$cshow :: MessageTextType -> [Char]
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" -> forall (f :: * -> *) a. Applicative f => a -> f a
pure MessageTextType
TextType
    Text
"m.emote" -> forall (f :: * -> *) a. Applicative f => a -> f a
pure MessageTextType
EmoteType
    Text
"m.notice" -> forall (f :: * -> *) a. Applicative f => a -> f a
pure MessageTextType
NoticeType
    Text
_ -> forall (m :: * -> *) a. MonadPlus m => m a
mzero
  parseJSON Value
_ = forall (m :: * -> *) a. MonadPlus m => m a
mzero

instance ToJSON MessageTextType where
  toJSON :: MessageTextType -> Value
toJSON MessageTextType
mt = Text -> Value
String 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 -> [Char]
forall a.
(Int -> a -> ShowS) -> (a -> [Char]) -> ([a] -> ShowS) -> Show a
showList :: [MessageText] -> ShowS
$cshowList :: [MessageText] -> ShowS
show :: MessageText -> [Char]
$cshow :: MessageText -> [Char]
showsPrec :: Int -> MessageText -> ShowS
$cshowsPrec :: Int -> MessageText -> ShowS
Show, MessageText -> MessageText -> Bool
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
      forall (f :: * -> *) a b. Functor f => (a -> b) -> f a -> f b
<$> Object
v forall a. FromJSON a => Object -> Key -> Parser a
.: Key
"body"
        forall (f :: * -> *) a b. Applicative f => f (a -> b) -> f a -> f b
<*> Object
v forall a. FromJSON a => Object -> Key -> Parser a
.: Key
"msgtype"
        forall (f :: * -> *) a b. Applicative f => f (a -> b) -> f a -> f b
<*> Object
v forall a. FromJSON a => Object -> Key -> Parser (Maybe a)
.:? Key
"format"
        forall (f :: * -> *) a b. Applicative f => f (a -> b) -> f a -> f b
<*> Object
v forall a. FromJSON a => Object -> Key -> Parser (Maybe a)
.:? Key
"formatted_body"
  parseJSON Value
_ = forall (m :: * -> *) a. MonadPlus m => m a
mzero

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

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

newtype RoomMessage
  = RoomMessageText MessageText
  deriving (Int -> RoomMessage -> ShowS
[RoomMessage] -> ShowS
RoomMessage -> [Char]
forall a.
(Int -> a -> ShowS) -> (a -> [Char]) -> ([a] -> ShowS) -> Show a
showList :: [RoomMessage] -> ShowS
$cshowList :: [RoomMessage] -> ShowS
show :: RoomMessage -> [Char]
$cshow :: RoomMessage -> [Char]
showsPrec :: Int -> RoomMessage -> ShowS
$cshowsPrec :: Int -> RoomMessage -> ShowS
Show, RoomMessage -> RoomMessage -> Bool
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 -> forall a. ToJSON a => a -> Value
toJSON MessageText
mt

instance FromJSON RoomMessage where
  parseJSON :: Value -> Parser RoomMessage
parseJSON Value
x = MessageText -> RoomMessage
RoomMessageText forall (f :: * -> *) a b. Functor f => (a -> b) -> f a -> f b
<$> 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 -> [Char]
forall a.
(Int -> a -> ShowS) -> (a -> [Char]) -> ([a] -> ShowS) -> Show a
showList :: [RelatedMessage] -> ShowS
$cshowList :: [RelatedMessage] -> ShowS
show :: RelatedMessage -> [Char]
$cshow :: RelatedMessage -> [Char]
showsPrec :: Int -> RelatedMessage -> ShowS
$cshowsPrec :: Int -> RelatedMessage -> ShowS
Show, RelatedMessage -> RelatedMessage -> Bool
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
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 -> [Char]
forall a.
(Int -> a -> ShowS) -> (a -> [Char]) -> ([a] -> ShowS) -> Show a
showList :: [Event] -> ShowS
$cshowList :: [Event] -> ShowS
show :: Event -> [Char]
$cshow :: Event -> [Char]
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 -> forall a. ToJSON a => a -> Value
toJSON RoomMessage
msg
    EventRoomReply EventID
eventID RoomMessage
msg ->
      let replyAttr :: [Pair]
replyAttr =
            [ Key
"m.relates_to"
                forall kv v. (KeyValue kv, ToJSON v) => Key -> v -> kv
.= [Pair] -> Value
object
                  [ Key
"m.in_reply_to" forall kv v. (KeyValue kv, ToJSON v) => Key -> v -> kv
.= forall a. ToJSON a => a -> Value
toJSON EventID
eventID
                  ]
            ]
       in [Pair] -> Value
object forall a b. (a -> b) -> a -> b
$ [Pair]
replyAttr 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"
                forall kv v. (KeyValue kv, ToJSON v) => Key -> v -> kv
.= [Pair] -> Value
object
                  [ Key
"rel_type" forall kv v. (KeyValue kv, ToJSON v) => Key -> v -> kv
.= (Text
"m.replace" :: Text),
                    Key
"event_id" forall kv v. (KeyValue kv, ToJSON v) => Key -> v -> kv
.= Text
eventID
                  ],
              Key
"m.new_content" forall kv v. (KeyValue kv, ToJSON v) => Key -> v -> kv
.= [Pair] -> Value
object (RoomMessage -> [Pair]
roomMessageAttr RoomMessage
newMsg)
            ]
       in [Pair] -> Value
object forall a b. (a -> b) -> a -> b
$ [Pair]
editAttr 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 forall (f :: * -> *) a. Alternative f => f a -> f a -> f a
<|> Parser Event
parseMessage forall (f :: * -> *) a. Alternative f => f a -> f a -> f a
<|> forall (f :: * -> *) a. Applicative f => a -> f a
pure (Object -> Event
EventUnknown Object
content)
    where
      parseMessage :: Parser Event
parseMessage = RoomMessage -> Event
EventRoomMessage forall (f :: * -> *) a b. Functor f => (a -> b) -> f a -> f b
<$> forall a. FromJSON a => Value -> Parser a
parseJSON (Object -> Value
Object Object
content)
      parseRelated :: Parser Event
parseRelated = do
        Value
relateM <- Object
content 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 forall (f :: * -> *) a. Alternative f => f a -> f a -> f a
<|> Object -> Parser Event
parseReplace Object
relate
          Value
_ -> forall (m :: * -> *) a. MonadPlus m => m a
mzero
      parseReply :: Object -> Parser Event
parseReply Object
relate =
        EventID -> RoomMessage -> Event
EventRoomReply forall (f :: * -> *) a b. Functor f => (a -> b) -> f a -> f b
<$> Object
relate forall a. FromJSON a => Object -> Key -> Parser a
.: Key
"m.in_reply_to" forall (f :: * -> *) a b. Applicative f => f (a -> b) -> f a -> f b
<*> 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 forall a. FromJSON a => Object -> Key -> Parser a
.: Key
"rel_type"
        if Text
rel_type forall a. Eq a => a -> a -> Bool
== (Text
"m.replace" :: Text)
          then do
            EventID
ev <- Text -> EventID
EventID forall (f :: * -> *) a b. Functor f => (a -> b) -> f a -> f b
<$> Object
relate forall a. FromJSON a => Object -> Key -> Parser a
.: Key
"event_id"
            RoomMessage
msg <- forall a. FromJSON a => Value -> Parser a
parseJSON (Object -> Value
Object Object
content)
            (EventID, RoomMessage) -> RoomMessage -> Event
EventRoomEdit (EventID
ev, RoomMessage
msg) forall (f :: * -> *) a b. Functor f => (a -> b) -> f a -> f b
<$> Object
content forall a. FromJSON a => Object -> Key -> Parser a
.: Key
"m.new_content"
          else forall (m :: * -> *) a. MonadPlus m => m a
mzero
  parseJSON Value
_ = 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
_ -> forall a. HasCallStack => [Char] -> a
error forall a b. (a -> b) -> a -> b
$ [Char]
"Event is not implemented: " forall a. Semigroup a => a -> a -> a
<> forall a. Show a => a -> [Char]
show Event
event

newtype EventID = EventID {EventID -> Text
unEventID :: Text} deriving (Int -> EventID -> ShowS
[EventID] -> ShowS
EventID -> [Char]
forall a.
(Int -> a -> ShowS) -> (a -> [Char]) -> ([a] -> ShowS) -> Show a
showList :: [EventID] -> ShowS
$cshowList :: [EventID] -> ShowS
show :: EventID -> [Char]
$cshow :: EventID -> [Char]
showsPrec :: Int -> EventID -> ShowS
$cshowsPrec :: Int -> EventID -> ShowS
Show, EventID -> EventID -> Bool
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
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
Ord)

instance FromJSON EventID where
  parseJSON :: Value -> Parser EventID
parseJSON (Object Object
v) = Text -> EventID
EventID forall (f :: * -> *) a b. Functor f => (a -> b) -> f a -> f b
<$> Object
v forall a. FromJSON a => Object -> Key -> Parser a
.: Key
"event_id"
  parseJSON Value
_ = 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" forall kv v. (KeyValue kv, ToJSON v) => Key -> v -> kv
.= Text
v]