From 4f857d1802017fc66d4c630da036856d2585b50d Mon Sep 17 00:00:00 2001 From: Sergey Kazenyuk Date: Mon, 2 Feb 2026 01:05:27 +0100 Subject: [PATCH 1/3] add support for m.reaction events --- src/Network/Matrix/Client.hs | 1 + src/Network/Matrix/Events.hs | 37 ++++++++++++++++++++++++++++++------ 2 files changed, 32 insertions(+), 6 deletions(-) diff --git a/src/Network/Matrix/Client.hs b/src/Network/Matrix/Client.hs index 22901fc..2c944ba 100644 --- a/src/Network/Matrix/Client.hs +++ b/src/Network/Matrix/Client.hs @@ -1228,6 +1228,7 @@ mkReply room re mt = EventRoomMessage (RoomMessageText oldMT) -> updateText oldMT EventRoomReply _ (RoomMessageText oldMT) -> updateText oldMT EventRoomEdit _ (RoomMessageText oldMT) -> updateText oldMT + EventReaction _ _ -> error $ "Can't reply to reaction" EventUnknown x -> error $ "Can't reply to " <> show x in EventRoomReply eventID (RoomMessageText newMessage) diff --git a/src/Network/Matrix/Events.hs b/src/Network/Matrix/Events.hs index 06644e8..c2980e7 100644 --- a/src/Network/Matrix/Events.hs +++ b/src/Network/Matrix/Events.hs @@ -7,6 +7,7 @@ module Network.Matrix.Events ( RoomMessage (..), Event (..), EventID (..), + Annotation (..), eventType, ) where @@ -62,6 +63,9 @@ messageTextAttr msg = format = omitNull "format" $ mtFormat msg formattedBody = omitNull "formatted_body" $ mtFormattedBody msg +reactionAttr :: [Pair] +reactionAttr = [ "msg_type" .= ("m.reaction" :: Text) ] + instance ToJSON MessageText where toJSON = object . messageTextAttr @@ -87,11 +91,13 @@ data RelatedMessage = RelatedMessage deriving (Show, Eq) data Event - = EventRoomMessage RoomMessage + = EventRoomMessage RoomMessage -- | m.room.message | -- | 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 + | -- https://spec.matrix.org/latest/client-server-api/#mreaction + EventReaction EventID Annotation | EventUnknown Object deriving (Eq, Show) @@ -116,6 +122,17 @@ instance ToJSON Event where , "m.new_content" .= object (roomMessageAttr newMsg) ] in object $ editAttr <> roomMessageAttr msg + -- | https://spec.matrix.org/latest/client-server-api/#mreaction + EventReaction (EventID eventID) (Annotation annotationText) -> + let attr = + [ "m.relates_to" + .= object + [ "rel_type" .= ("m.annotation" :: Text) + , "event_id" .= eventID + , "key" .= annotationText + ] + ] + in object $ attr <> reactionAttr EventUnknown v -> Object v instance FromJSON Event where @@ -126,18 +143,23 @@ instance FromJSON Event where parseRelated = do relateM <- content .: "m.relates_to" case relateM of - Object relate -> parseReply relate <|> parseReplace relate + Object relate -> parseReply relate + <|> parseByRelType relate _ -> mzero parseReply relate = EventRoomReply <$> relate .: "m.in_reply_to" <*> parseJSON (Object content) - parseReplace relate = do + parseByRelType relate = do rel_type <- relate .: "rel_type" - if rel_type == ("m.replace" :: Text) - then do + case (rel_type :: Text) of + "m.replace" -> do ev <- EventID <$> relate .: "event_id" msg <- parseJSON (Object content) EventRoomEdit (ev, msg) <$> content .: "m.new_content" - else mzero + "m.annotation" -> do + ev <- EventID <$> relate .: "event_id" + annotation <- Annotation <$> relate .: "key" + pure $ EventReaction ev annotation + _ -> mzero parseJSON _ = mzero eventType :: Event -> Text @@ -145,8 +167,11 @@ eventType event = case event of EventRoomMessage _ -> "m.room.message" EventRoomReply _ _ -> "m.room.message" EventRoomEdit _ _ -> "m.room.message" + EventReaction _ _ -> "m.reaction" -- https://spec.matrix.org/latest/client-server-api/#mreaction EventUnknown _ -> error $ "Event is not implemented: " <> show event +newtype Annotation = Annotation {unAnnotation :: Text} deriving (Show, Eq, Ord) + newtype EventID = EventID {unEventID :: Text} deriving (Show, Eq, Ord) instance FromJSON EventID where From 9b0414d5c56966cec6660db6f5c561114ceae32f Mon Sep 17 00:00:00 2001 From: Sergey Kazenyuk Date: Sun, 15 Feb 2026 17:25:02 +0100 Subject: [PATCH 2/3] Add some references to the matrix specification --- src/Network/Matrix/Events.hs | 12 +++++++++--- 1 file changed, 9 insertions(+), 3 deletions(-) diff --git a/src/Network/Matrix/Events.hs b/src/Network/Matrix/Events.hs index c2980e7..61738a8 100644 --- a/src/Network/Matrix/Events.hs +++ b/src/Network/Matrix/Events.hs @@ -91,12 +91,13 @@ data RelatedMessage = RelatedMessage deriving (Show, Eq) data Event - = EventRoomMessage RoomMessage -- | m.room.message + = -- | [`m.room.message`](https://spec.matrix.org/v1.17/client-server-api/#mroommessage) + 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 - | -- https://spec.matrix.org/latest/client-server-api/#mreaction + | -- [`m.reaction`](https://spec.matrix.org/v1.17/client-server-api/#mreaction) EventReaction EventID Annotation | EventUnknown Object deriving (Eq, Show) @@ -122,7 +123,6 @@ instance ToJSON Event where , "m.new_content" .= object (roomMessageAttr newMsg) ] in object $ editAttr <> roomMessageAttr msg - -- | https://spec.matrix.org/latest/client-server-api/#mreaction EventReaction (EventID eventID) (Annotation annotationText) -> let attr = [ "m.relates_to" @@ -140,21 +140,27 @@ instance FromJSON Event where parseRelated <|> parseMessage <|> pure (EventUnknown content) where parseMessage = EventRoomMessage <$> parseJSON (Object content) + -- https://spec.matrix.org/v1.17/client-server-api/#forming-relationships-between-events parseRelated = do relateM <- content .: "m.relates_to" case relateM of Object relate -> parseReply relate <|> parseByRelType relate _ -> mzero + -- rich replies is a special kind of a relationship not using rel_type + -- https://spec.matrix.org/v1.17/client-server-api/#rich-replies parseReply relate = EventRoomReply <$> relate .: "m.in_reply_to" <*> parseJSON (Object content) + -- relationships using rel_type parseByRelType relate = do rel_type <- relate .: "rel_type" case (rel_type :: Text) of + -- https://spec.matrix.org/v1.17/client-server-api/#event-replacements "m.replace" -> do ev <- EventID <$> relate .: "event_id" msg <- parseJSON (Object content) EventRoomEdit (ev, msg) <$> content .: "m.new_content" + -- https://spec.matrix.org/v1.17/client-server-api/#mannotation-relationship-type "m.annotation" -> do ev <- EventID <$> relate .: "event_id" annotation <- Annotation <$> relate .: "key" From 1e02d5c7d47534398c75a6bd7ccaaea209762b83 Mon Sep 17 00:00:00 2001 From: Sergey Kazenyuk Date: Sun, 15 Feb 2026 17:26:08 +0100 Subject: [PATCH 3/3] Add m.reaction decode test --- test/Spec.hs | 7 +++++++ test/data/reaction.json | 7 +++++++ 2 files changed, 14 insertions(+) create mode 100644 test/data/reaction.json diff --git a/test/Spec.hs b/test/Spec.hs index 4a096b6..4598df6 100644 --- a/test/Spec.hs +++ b/test/Spec.hs @@ -96,6 +96,13 @@ spec = describe "unit tests" $ do mtBody srcMsg `shouldBe` " * > :typo" mtBody message `shouldBe` "> :hello" _ -> error $ show resp + it "decode reaction" $ do + resp <- decodeResp <$> BS.readFile "test/data/reaction.json" + case resp of + Right (Right (EventReaction eventID (Annotation annText))) -> do + eventID `shouldBe` EventID "$eventID" + annText `shouldBe` "\128077" -- :+1: + _ -> error $ show resp it "encode room message" $ encodePretty (RoomMessageText (MessageText "Hello" TextType Nothing Nothing)) `shouldBe` "{\"body\":\"Hello\",\"msgtype\":\"m.text\"}" diff --git a/test/data/reaction.json b/test/data/reaction.json new file mode 100644 index 0000000..e044670 --- /dev/null +++ b/test/data/reaction.json @@ -0,0 +1,7 @@ +{ + "m.relates_to": { + "event_id": "$eventID", + "key": "👍", + "rel_type": "m.annotation" + } +}