Add support for reactions (m.reaction event)

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)
 

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,14 @@ data RelatedMessage = RelatedMessage
     deriving (Show, Eq)
 
 data Event
-    = EventRoomMessage RoomMessage
+    = -- | [`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
+    | -- [`m.reaction`](https://spec.matrix.org/v1.17/client-server-api/#mreaction)
+      EventReaction EventID Annotation
     | EventUnknown Object
     deriving (Eq, Show)
 
@@ -116,37 +123,61 @@ instance ToJSON Event where
                     , "m.new_content" .= object (roomMessageAttr newMsg)
                     ]
              in object $ editAttr <> roomMessageAttr msg
+        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
     parseJSON (Object content) =
         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 <|> parseReplace relate
+                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)
-        parseReplace relate = do
+        -- relationships using rel_type
+        parseByRelType relate = do
             rel_type <- relate .: "rel_type"
-            if rel_type == ("m.replace" :: Text)
-                then do
+            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"
-                else mzero
+                -- https://spec.matrix.org/v1.17/client-server-api/#mannotation-relationship-type
+                "m.annotation" -> do
+                    ev <- EventID <$> relate .: "event_id"
+                    annotation <- Annotation <$> relate .: "key"
+                    pure $ EventReaction ev annotation
+                _ -> mzero
     parseJSON _ = mzero
 
 eventType :: Event -> Text
 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

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\"}"

test/data/reaction.json

@@ -0,0 +1,7 @@
+{
+  "m.relates_to": {
+    "event_id": "$eventID",
+    "key": "👍",
+    "rel_type": "m.annotation"
+  }
+}