{-# LANGUAGE OverloadedStrings #-}
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
|
EventRoomReply EventID RoomMessage
|
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]