diff --git a/CHANGELOG.md b/CHANGELOG.md --- a/CHANGELOG.md +++ b/CHANGELOG.md @@ -1,5 +1,16 @@ # Changelog +## 0.1.2.0 + +- Add filtering client function +- Add sync client function +- Add createRoom client function +- Add retryWithLog and syncPoll utility function +- Add mkReply helper utility function +- Add reply and edit Event +- Change MessageText to include the TextType +- Change RoomEvent to use Author and EventID newtype + ## 0.1.1.0 - Ensure aeson encoding test is reproducible using aeson-pretty diff --git a/README.md b/README.md deleted file mode 100644 --- a/README.md +++ /dev/null @@ -1,21 +0,0 @@ -# matrix-client-haskell - -[![Hackage](https://img.shields.io/hackage/v/matrix-client.svg)](https://hackage.haskell.org/package/matrix-client) - -A client library for [matrix.org](https://matrix.org) - -## Contribute - -To work on this project you need a Haskell toolchain, for example on fedora: - -```ShellSession -$ sudo dnf install -y ghc cabal-install && cabal update -``` - -Run the tests: - -```ShellSession -$ cabal test -``` - -If you experience any difficulties, please don't hesistate to raise an issue. diff --git a/matrix-client.cabal b/matrix-client.cabal --- a/matrix-client.cabal +++ b/matrix-client.cabal @@ -1,6 +1,6 @@ cabal-version: 2.4 name: matrix-client -version: 0.1.1.0 +version: 0.1.2.0 synopsis: A matrix client library description: Matrix client is a library to interface with https://matrix.org. @@ -9,6 +9,8 @@ . Read the "Network.Matrix.Tutorial" for a detailed tutorial. . + Please see the README at https://github.com/softwarefactory-project/matrix-client-haskell#readme + . homepage: https://github.com/softwarefactory-project/matrix-client-haskell#readme bug-reports: https://github.com/softwarefactory-project/matrix-client-haskell/issues license: Apache-2.0 @@ -19,7 +21,7 @@ category: Network build-type: Simple extra-doc-files: CHANGELOG.md - README.md +extra-source-files: test/data/*.json tested-with: GHC == 8.10.4 source-repository head @@ -28,6 +30,7 @@ common common-options build-depends: base >= 4.11.0.0 && < 5 + , aeson-casing >= 0.2.0.0 && < 0.3.0.0 , aeson >= 1.0.0.0 && < 1.6 ghc-options: -Wall -Wcompat @@ -47,6 +50,7 @@ build-depends: SHA ^>= 1.6 , base64 , bytestring + , containers , exceptions , hashable , http-client >= 0.5.0 && < 0.8 @@ -65,6 +69,7 @@ , Network.Matrix.Tutorial other-modules: Network.Matrix.Events , Network.Matrix.Internal + , Network.Matrix.Room test-suite unit import: common-options, lib-depends @@ -72,16 +77,8 @@ hs-source-dirs: test, src main-is: Spec.hs build-depends: base + , bytestring , aeson-pretty , hspec >= 2 , matrix-client , text - -test-suite doctest - type: exitcode-stdio-1.0 - default-language: Haskell2010 - hs-source-dirs: test - ghc-options: -threaded -Wall - main-is: Doctest.hs - build-depends: base - , doctest >= 0.9.3 diff --git a/src/Network/Matrix/Client.hs b/src/Network/Matrix/Client.hs --- a/src/Network/Matrix/Client.hs +++ b/src/Network/Matrix/Client.hs @@ -1,4 +1,8 @@ +{-# LANGUAGE DeriveGeneric #-} +{-# LANGUAGE DerivingStrategies #-} {-# LANGUAGE GeneralizedNewtypeDeriving #-} +{-# LANGUAGE LambdaCase #-} +{-# LANGUAGE NumericUnderscores #-} {-# LANGUAGE OverloadedStrings #-} {-# LANGUAGE RecordWildCards #-} @@ -12,17 +16,25 @@ createSession, -- * API + MatrixM, MatrixIO, MatrixError (..), retry, + retryWithLog, -- * User data UserID (..), getTokenOwner, + -- * Room management + RoomCreatePreset (..), + RoomCreateRequest (..), + createRoom, + -- * Room participation TxnID (..), sendMessage, + mkReply, module Network.Matrix.Events, -- * Room membership @@ -31,18 +43,61 @@ joinRoom, joinRoomById, leaveRoomById, + + -- * Filter + EventFormat (..), + EventFilter (..), + defaultEventFilter, + eventFilterAll, + RoomEventFilter (..), + defaultRoomEventFilter, + roomEventFilterAll, + StateFilter (..), + defaultStateFilter, + stateFilterAll, + RoomFilter (..), + defaultRoomFilter, + Filter (..), + defaultFilter, + FilterID (..), + messageFilter, + createFilter, + getFilter, + + -- * Events + sync, + getTimelines, + syncPoll, + Author (..), + Presence (..), + RoomEvent (..), + RoomSummary (..), + TimelineSync (..), + InvitedRoomSync (..), + JoinedRoomSync (..), + SyncResult (..), + SyncResultRoom (..), ) where import Control.Monad (mzero) -import Data.Aeson (FromJSON (..), Value (Object), encode, (.:)) +import Control.Monad.IO.Class (MonadIO(liftIO)) +import Data.Aeson (FromJSON (..), ToJSON (..), Value (Object, String), encode, genericParseJSON, genericToJSON, object, (.:), (.:?), (.=)) +import qualified Data.Aeson as Aeson +import Data.Aeson.Casing (aesonPrefix, snakeCase) import Data.Hashable (Hashable) -import Data.Text (Text) +import Data.List.NonEmpty (NonEmpty (..)) +import Data.Map.Strict (Map, foldrWithKey) +import Data.Maybe (fromMaybe) +import Data.Text (Text, pack) +import qualified Data.Text as Text import Data.Text.Encoding (decodeUtf8, encodeUtf8) +import GHC.Generics import qualified Network.HTTP.Client as HTTP import Network.HTTP.Types.URI (urlEncode) import Network.Matrix.Events import Network.Matrix.Internal +import Network.Matrix.Room -- $setup -- >>> import Data.Aeson (decode) @@ -74,6 +129,36 @@ getTokenOwner session = doRequest session =<< mkRequest session True "/_matrix/client/r0/account/whoami" +-- | A workaround data type to handle room create error being reported with a {message: "error"} response +data CreateRoomResponse = CreateRoomResponse + { crrMessage :: Maybe Text, + crrID :: Maybe Text + } + +instance FromJSON CreateRoomResponse where + parseJSON (Object o) = CreateRoomResponse <$> o .:? "message" <*> o .:? "room_id" + parseJSON _ = mzero + +createRoom :: ClientSession -> RoomCreateRequest -> MatrixIO RoomID +createRoom session rcr = do + request <- mkRequest session True "/_matrix/client/r0/createRoom" + toRoomID + <$> doRequest + session + ( request + { HTTP.method = "POST", + HTTP.requestBody = HTTP.RequestBodyLBS $ encode rcr + } + ) + where + toRoomID :: Either MatrixError CreateRoomResponse -> Either MatrixError RoomID + toRoomID resp = case resp of + Left err -> Left err + Right crr -> case (crrID crr, crrMessage crr) of + (Just roomID, _) -> pure $ RoomID roomID + (_, Just message) -> Left $ MatrixError "UNKNOWN" message Nothing + _ -> Left $ MatrixError "UNKOWN" "" Nothing + newtype TxnID = TxnID Text deriving (Show, Eq) sendMessage :: ClientSession -> RoomID -> Event -> TxnID -> MatrixIO EventID @@ -90,7 +175,7 @@ path = "/_matrix/client/r0/rooms/" <> roomId <> "/send/" <> eventId <> "/" <> txnId eventId = eventType event -newtype RoomID = RoomID Text deriving (Show, Eq, Hashable) +newtype RoomID = RoomID Text deriving (Show, Eq, Ord, Hashable) instance FromJSON RoomID where parseJSON (Object v) = RoomID <$> v .: "room_id" @@ -136,3 +221,451 @@ ensureEmptyObject value = case value of Object xs | xs == mempty -> () _anyOther -> error $ "Unknown leave response: " <> show value + +------------------------------------------------------------------------------- +-- https://matrix.org/docs/spec/client_server/latest#post-matrix-client-r0-user-userid-filter +newtype FilterID = FilterID Text deriving (Show, Eq, Hashable) + +instance FromJSON FilterID where + parseJSON (Object v) = FilterID <$> v .: "filter_id" + parseJSON _ = mzero + +data EventFormat = Client | Federation deriving (Show, Eq) + +instance ToJSON EventFormat where + toJSON ef = case ef of + Client -> "client" + Federation -> "federation" + +instance FromJSON EventFormat where + parseJSON v = case v of + (String "client") -> pure Client + (String "federation") -> pure Federation + _ -> mzero + +data EventFilter = EventFilter + { efLimit :: Maybe Int, + efNotSenders :: Maybe [Text], + efNotTypes :: Maybe [Text], + efSenders :: Maybe [Text], + efTypes :: Maybe [Text] + } + deriving (Show, Eq, Generic) + +defaultEventFilter :: EventFilter +defaultEventFilter = EventFilter Nothing Nothing Nothing Nothing Nothing + +-- | A filter that should match nothing +eventFilterAll :: EventFilter +eventFilterAll = defaultEventFilter {efLimit = Just 0, efNotTypes = Just ["*"]} + +aesonOptions :: Aeson.Options +aesonOptions = (aesonPrefix snakeCase) {Aeson.omitNothingFields = True} + +instance ToJSON EventFilter where + toJSON = genericToJSON aesonOptions + +instance FromJSON EventFilter where + parseJSON = genericParseJSON aesonOptions + +data RoomEventFilter = RoomEventFilter + { refLimit :: Maybe Int, + refNotSenders :: Maybe [Text], + refNotTypes :: Maybe [Text], + refSenders :: Maybe [Text], + refTypes :: Maybe [Text], + refLazyLoadMembers :: Maybe Bool, + refIncludeRedundantMembers :: Maybe Bool, + refNotRooms :: Maybe [Text], + refRooms :: Maybe [Text], + refContainsUrl :: Maybe Bool + } + deriving (Show, Eq, Generic) + +defaultRoomEventFilter :: RoomEventFilter +defaultRoomEventFilter = RoomEventFilter Nothing Nothing Nothing Nothing Nothing Nothing Nothing Nothing Nothing Nothing + +-- | A filter that should match nothing +roomEventFilterAll :: RoomEventFilter +roomEventFilterAll = defaultRoomEventFilter {refLimit = Just 0, refNotTypes = Just ["*"]} + +instance ToJSON RoomEventFilter where + toJSON = genericToJSON aesonOptions + +instance FromJSON RoomEventFilter where + parseJSON = genericParseJSON aesonOptions + +data StateFilter = StateFilter + { sfLimit :: Maybe Int, + sfNotSenders :: Maybe [Text], + sfNotTypes :: Maybe [Text], + sfSenders :: Maybe [Text], + sfTypes :: Maybe [Text], + sfLazyLoadMembers :: Maybe Bool, + sfIncludeRedundantMembers :: Maybe Bool, + sfNotRooms :: Maybe [Text], + sfRooms :: Maybe [Text], + sfContains_url :: Maybe Bool + } + deriving (Show, Eq, Generic) + +defaultStateFilter :: StateFilter +defaultStateFilter = StateFilter Nothing Nothing Nothing Nothing Nothing Nothing Nothing Nothing Nothing Nothing + +stateFilterAll :: StateFilter +stateFilterAll = defaultStateFilter {sfLimit = Just 0, sfNotTypes = Just ["*"]} + +instance ToJSON StateFilter where + toJSON = genericToJSON aesonOptions + +instance FromJSON StateFilter where + parseJSON = genericParseJSON aesonOptions + +data RoomFilter = RoomFilter + { rfNotRooms :: Maybe [Text], + rfRooms :: Maybe [Text], + rfEphemeral :: Maybe RoomEventFilter, + rfIncludeLeave :: Maybe Bool, + rfState :: Maybe StateFilter, + rfTimeline :: Maybe RoomEventFilter, + rfAccountData :: Maybe RoomEventFilter + } + deriving (Show, Eq, Generic) + +defaultRoomFilter :: RoomFilter +defaultRoomFilter = RoomFilter Nothing Nothing Nothing Nothing Nothing Nothing Nothing + +instance ToJSON RoomFilter where + toJSON = genericToJSON aesonOptions + +instance FromJSON RoomFilter where + parseJSON = genericParseJSON aesonOptions + +data Filter = Filter + { filterEventFields :: Maybe [Text], + filterEventFormat :: Maybe EventFormat, + filterPresence :: Maybe EventFilter, + filterAccountData :: Maybe EventFilter, + filterRoom :: Maybe RoomFilter + } + deriving (Show, Eq, Generic) + +defaultFilter :: Filter +defaultFilter = Filter Nothing Nothing Nothing Nothing Nothing + +-- | A filter to keep all the messages +messageFilter :: Filter +messageFilter = + defaultFilter + { filterPresence = Just eventFilterAll, + filterAccountData = Just eventFilterAll, + filterRoom = Just roomFilter + } + where + roomFilter = + defaultRoomFilter + { rfEphemeral = Just roomEventFilterAll, + rfState = Just stateFilterAll, + rfTimeline = Just timelineFilter, + rfAccountData = Just roomEventFilterAll + } + timelineFilter = + defaultRoomEventFilter + { refTypes = Just ["m.room.message"] + } + +instance ToJSON Filter where + toJSON = genericToJSON aesonOptions + +instance FromJSON Filter where + parseJSON = genericParseJSON aesonOptions + +-- | Upload a new filter definition to the homeserver +-- https://matrix.org/docs/spec/client_server/latest#post-matrix-client-r0-user-userid-filter +createFilter :: + -- | The client session, use 'createSession' to get one. + ClientSession -> + -- | The userID, use 'getTokenOwner' to get it. + UserID -> + -- | The filter definition, use 'defaultFilter' to create one or use the 'messageFilter' example. + Filter -> + -- | The function returns a 'FilterID' suitable for the 'sync' function. + MatrixIO FilterID +createFilter session (UserID userID) body = do + request <- mkRequest session True path + doRequest + session + ( request + { HTTP.method = "POST", + HTTP.requestBody = HTTP.RequestBodyLBS $ encode body + } + ) + where + path = "/_matrix/client/r0/user/" <> userID <> "/filter" + +getFilter :: ClientSession -> UserID -> FilterID -> MatrixIO Filter +getFilter session (UserID userID) (FilterID filterID) = + doRequest session =<< mkRequest session True path + where + path = "/_matrix/client/r0/user/" <> userID <> "/filter/" <> filterID + +------------------------------------------------------------------------------- +-- https://matrix.org/docs/spec/client_server/latest#get-matrix-client-r0-sync +newtype Author = Author {unAuthor :: Text} + deriving (Show, Eq) + deriving newtype (FromJSON, ToJSON) + +data RoomEvent = RoomEvent + { reContent :: Event, + reType :: Text, + reEventId :: EventID, + reSender :: Author + } + deriving (Show, Eq, Generic) + +data RoomSummary = RoomSummary + { rsJoinedMemberCount :: Maybe Int, + rsInvitedMemberCount :: Maybe Int + } + deriving (Show, Eq, Generic) + +data TimelineSync = TimelineSync + { tsEvents :: Maybe [RoomEvent], + tsLimited :: Maybe Bool, + tsPrevBatch :: Maybe Text + } + deriving (Show, Eq, Generic) + +data JoinedRoomSync = JoinedRoomSync + { jrsSummary :: Maybe RoomSummary, + jrsTimeline :: TimelineSync + } + deriving (Show, Eq, Generic) + +data Presence = Offline | Online | Unavailable deriving (Eq) + +instance Show Presence where + show = \case + Offline -> "offline" + Online -> "online" + Unavailable -> "unavailable" + +instance ToJSON Presence where + toJSON ef = String . pack . show $ ef + +instance FromJSON Presence where + parseJSON v = case v of + (String "offline") -> pure Offline + (String "online") -> pure Online + (String "unavailable") -> pure Unavailable + _ -> mzero + +data SyncResult = SyncResult + { srNextBatch :: Text, + srRooms :: Maybe SyncResultRoom + } + deriving (Show, Eq, Generic) + +data SyncResultRoom = SyncResultRoom + { srrJoin :: Maybe (Map Text JoinedRoomSync) + , srrInvite :: Maybe (Map Text InvitedRoomSync) + } + deriving (Show, Eq, Generic) + +data InvitedRoomSync = InvitedRoomSync + deriving (Show, Eq, Generic) + +unFilterID :: FilterID -> Text +unFilterID (FilterID x) = x + +------------------------------------------------------------------------------- +-- https://matrix.org/docs/spec/client_server/latest#forming-relationships-between-events + +headMaybe :: [a] -> Maybe a +headMaybe xs = case xs of + [] -> Nothing + (x : _) -> Just x + +tail' :: [a] -> [a] +tail' xs = case xs of + [] -> [] + (_ : rest) -> rest + +-- | An helper to create a reply body +-- +-- >>> let sender = Author "foo@matrix.org" +-- >>> addReplyBody sender "Hello" "hi" +-- "> Hello\n\nhi" +-- +-- >>> addReplyBody sender "" "hey" +-- "> \n\nhey" +-- +-- >>> addReplyBody sender "a multi\nline" "resp" +-- "> a multi\n> line\n\nresp" +addReplyBody :: Author -> Text -> Text -> Text +addReplyBody (Author author) old reply = + let oldLines = Text.lines old + headLine = "> <" <> author <> ">" <> maybe "" (mappend " ") (headMaybe oldLines) + newBody = [headLine] <> map (mappend "> ") (tail' oldLines) <> [""] <> [reply] + in Text.dropEnd 1 $ Text.unlines newBody + +addReplyFormattedBody :: RoomID -> EventID -> Author -> Text -> Text -> Text +addReplyFormattedBody (RoomID roomID) (EventID eventID) (Author author) old reply = + Text.unlines + [ "", + "
", + " roomID <> "/" <> eventID <> "\">In reply to", + " author <> "\">" <> author <> "", + "
", + " " <> old, + "
", + "", + reply + ] + +-- | Convert body by encoding HTML special char +-- +-- >>> toFormattedBody "& " +-- "& <test>" +toFormattedBody :: Text -> Text +toFormattedBody = Text.concatMap char + where + char x = case x of + '<' -> "<" + '>' -> ">" + '&' -> "&" + _ -> Text.singleton x + +-- | Prepare a reply event +mkReply :: + -- | The destination room, must match the original event + RoomID -> + -- | The original event + RoomEvent -> + -- | The reply message + MessageText -> + -- | The event to send + Event +mkReply room re mt = + let getFormattedBody mt' = fromMaybe (toFormattedBody $ mtBody mt') (mtFormattedBody mt') + eventID = reEventId re + author = reSender re + updateText oldMT = + oldMT + { mtFormat = Just "org.matrix.custom.html", + mtBody = addReplyBody author (mtBody oldMT) (mtBody mt), + mtFormattedBody = + Just $ + addReplyFormattedBody + room + eventID + author + (getFormattedBody oldMT) + (getFormattedBody mt) + } + + newMessage = case reContent re of + EventRoomMessage (RoomMessageText oldMT) -> updateText oldMT + EventRoomReply _ (RoomMessageText oldMT) -> updateText oldMT + EventRoomEdit _ (RoomMessageText oldMT) -> updateText oldMT + EventUnknown x -> error $ "Can't reply to " <> show x + in EventRoomReply eventID (RoomMessageText newMessage) + +sync :: ClientSession -> Maybe FilterID -> Maybe Text -> Maybe Presence -> Maybe Int -> MatrixIO SyncResult +sync session filterM sinceM presenceM timeoutM = do + request <- mkRequest session True "/_matrix/client/r0/sync" + doRequest session (HTTP.setQueryString qs request) + where + toQs name = \case + Nothing -> [] + Just v -> [(name, Just . encodeUtf8 $ v)] + qs = + toQs "filter" (unFilterID <$> filterM) + <> toQs "since" sinceM + <> toQs "set_presence" (pack . show <$> presenceM) + <> toQs "timeout" (pack . show <$> timeoutM) + +syncPoll :: + (MonadIO m) => + -- | The client session, use 'createSession' to get one. + ClientSession -> + -- | A sync filter, use 'createFilter' to get one. + Maybe FilterID -> + -- | A since value, get it from a previous sync result using the 'srNextBatch' field. + Maybe Text -> + -- | Set the session presence. + Maybe Presence -> + -- | Your callback to handle sync result. + (SyncResult -> m ()) -> + -- | This function does not return unless there is an error. + MatrixM m () +syncPoll session filterM sinceM presenceM cb = go sinceM + where + go since = do + syncResultE <- liftIO $ retry $ sync session filterM since presenceM (Just 10_000) + case syncResultE of + Left err -> pure (Left err) + Right sr -> cb sr >> go (Just (srNextBatch sr)) + +-- | Extract room events from a sync result +getTimelines :: SyncResult -> [(RoomID, NonEmpty RoomEvent)] +getTimelines sr = foldrWithKey getEvents [] joinedRooms + where + getEvents :: Text -> JoinedRoomSync -> [(RoomID, NonEmpty RoomEvent)] -> [(RoomID, NonEmpty RoomEvent)] + getEvents roomID jrs acc = case tsEvents (jrsTimeline jrs) of + Just (x : xs) -> (RoomID roomID, x :| xs) : acc + _ -> acc + joinedRooms = fromMaybe mempty $ srRooms sr >>= srrJoin + +------------------------------------------------------------------------------- +-- Derived JSON instances +instance ToJSON RoomEvent where + toJSON RoomEvent {..} = + object + [ "content" .= reContent, + "type" .= reType, + "event_id" .= unEventID reEventId, + "sender" .= reSender + ] + +instance FromJSON RoomEvent where + parseJSON (Object o) = do + eventId <- o .: "event_id" + RoomEvent <$> o .: "content" <*> o .: "type" <*> pure (EventID eventId) <*> o .: "sender" + parseJSON _ = mzero + +instance ToJSON RoomSummary where + toJSON = genericToJSON aesonOptions + +instance FromJSON RoomSummary where + parseJSON = genericParseJSON aesonOptions + +instance ToJSON TimelineSync where + toJSON = genericToJSON aesonOptions + +instance FromJSON TimelineSync where + parseJSON = genericParseJSON aesonOptions + +instance ToJSON JoinedRoomSync where + toJSON = genericToJSON aesonOptions + +instance FromJSON JoinedRoomSync where + parseJSON = genericParseJSON aesonOptions + +instance ToJSON InvitedRoomSync where + toJSON _ = object [] + +instance FromJSON InvitedRoomSync where + parseJSON _ = pure InvitedRoomSync + +instance ToJSON SyncResult where + toJSON = genericToJSON aesonOptions + +instance FromJSON SyncResult where + parseJSON = genericParseJSON aesonOptions + +instance ToJSON SyncResultRoom where + toJSON = genericToJSON aesonOptions + +instance FromJSON SyncResultRoom where + parseJSON = genericParseJSON aesonOptions diff --git a/src/Network/Matrix/Events.hs b/src/Network/Matrix/Events.hs --- a/src/Network/Matrix/Events.hs +++ b/src/Network/Matrix/Events.hs @@ -2,7 +2,8 @@ -- | Matrix event data type module Network.Matrix.Events - ( MessageText (..), + ( MessageTextType (..), + MessageText (..), RoomMessage (..), Event (..), EventID (..), @@ -10,59 +11,147 @@ ) where +import Control.Applicative ((<|>)) import Control.Monad (mzero) -import Data.Aeson (FromJSON (..), ToJSON (..), Value (Object), object, (.:), (.=)) +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 (Eq, Show) + +instance FromJSON MessageTextType where + parseJSON (String name) = case name of + "m.text" -> pure TextType + "m.emote" -> pure EmoteType + "m.notice" -> pure NoticeType + _ -> mzero + parseJSON _ = mzero + +instance ToJSON MessageTextType where + toJSON mt = String $ case mt of + TextType -> "m.text" + EmoteType -> "m.emote" + NoticeType -> "m.notice" + data MessageText = MessageText { mtBody :: Text, + mtType :: MessageTextType, mtFormat :: Maybe Text, mtFormattedBody :: Maybe Text } deriving (Show, Eq) +instance FromJSON MessageText where + parseJSON (Object v) = + MessageText + <$> v .: "body" + <*> v .: "msgtype" + <*> v .:? "format" + <*> v .:? "formatted_body" + parseJSON _ = mzero + messageTextAttr :: MessageText -> [Pair] messageTextAttr msg = - ["body" .= mtBody msg] <> format <> formattedBody + ["body" .= mtBody msg, "msgtype" .= mtType msg] <> format <> formattedBody where omitNull k vM = maybe [] (\v -> [k .= v]) vM format = omitNull "format" $ mtFormat msg formattedBody = omitNull "formatted_body" $ mtFormattedBody msg -data RoomMessage +instance ToJSON MessageText where + toJSON = object . messageTextAttr + +newtype RoomMessage = RoomMessageText MessageText - | RoomMessageEmote MessageText - | RoomMessageNotice MessageText deriving (Show, Eq) -roomMessageType :: RoomMessage -> Text -roomMessageType roomMessage = case roomMessage of - RoomMessageText _ -> "m.text" - RoomMessageEmote _ -> "m.emote" - RoomMessageNotice _ -> "m.notice" +roomMessageAttr :: RoomMessage -> [Pair] +roomMessageAttr rm = case rm of + RoomMessageText mt -> messageTextAttr mt instance ToJSON RoomMessage where - toJSON msg = - let msgtype = roomMessageType msg - attr = case msg of - RoomMessageText mt -> messageTextAttr mt - RoomMessageEmote mt -> messageTextAttr mt - RoomMessageNotice mt -> messageTextAttr mt - in object (["msgtype" .= msgtype] <> attr) + toJSON msg = case msg of + RoomMessageText mt -> toJSON mt -newtype Event = EventRoomMessage RoomMessage +instance FromJSON RoomMessage where + parseJSON x = RoomMessageText <$> parseJSON x +data RelatedMessage = RelatedMessage + { rmMessage :: RoomMessage, + rmRelatedTo :: EventID + } + deriving (Show, 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 (Eq, Show) + instance ToJSON Event where toJSON event = case event of EventRoomMessage msg -> toJSON msg + EventRoomReply eventID msg -> + let replyAttr = + [ "m.relates_to" + .= object + [ "m.in_reply_to" .= toJSON eventID + ] + ] + in object $ replyAttr <> roomMessageAttr msg + EventRoomEdit (EventID eventID, msg) newMsg -> + let editAttr = + [ "m.relates_to" + .= object + [ "rel_type" .= ("m.replace" :: Text), + "event_id" .= eventID + ], + "m.new_content" .= object (roomMessageAttr newMsg) + ] + in object $ editAttr <> roomMessageAttr msg + EventUnknown v -> Object v +instance FromJSON Event where + parseJSON (Object content) = + parseRelated <|> parseMessage <|> pure (EventUnknown content) + where + parseMessage = EventRoomMessage <$> parseJSON (Object content) + parseRelated = do + relateM <- content .: "m.relates_to" + case relateM of + Object relate -> parseReply relate <|> parseReplace relate + _ -> mzero + parseReply relate = + EventRoomReply <$> relate .: "m.in_reply_to" <*> parseJSON (Object content) + parseReplace relate = do + rel_type <- relate .: "rel_type" + if rel_type == ("m.replace" :: Text) + then do + ev <- EventID <$> relate .: "event_id" + msg <- parseJSON (Object content) + EventRoomEdit (ev, msg) <$> content .: "m.new_content" + else mzero + parseJSON _ = mzero + eventType :: Event -> Text eventType event = case event of EventRoomMessage _ -> "m.room.message" + EventRoomReply _ _ -> "m.room.message" + EventRoomEdit _ _ -> "m.room.message" + EventUnknown _ -> error $ "Event is not implemented: " <> show event -newtype EventID = EventID Text deriving (Show) +newtype EventID = EventID {unEventID :: Text} deriving (Show, Eq, Ord) instance FromJSON EventID where parseJSON (Object v) = EventID <$> v .: "event_id" parseJSON _ = mzero + +instance ToJSON EventID where + toJSON (EventID v) = object ["event_id" .= v] diff --git a/src/Network/Matrix/Identity.hs b/src/Network/Matrix/Identity.hs --- a/src/Network/Matrix/Identity.hs +++ b/src/Network/Matrix/Identity.hs @@ -14,6 +14,7 @@ MatrixIO, MatrixError (..), retry, + retryWithLog, -- * User data UserID (..), diff --git a/src/Network/Matrix/Internal.hs b/src/Network/Matrix/Internal.hs --- a/src/Network/Matrix/Internal.hs +++ b/src/Network/Matrix/Internal.hs @@ -1,3 +1,4 @@ +{-# LANGUAGE GeneralizedNewtypeDeriving #-} {-# LANGUAGE LambdaCase #-} {-# LANGUAGE NumericUnderscores #-} {-# LANGUAGE OverloadedStrings #-} @@ -9,11 +10,13 @@ import Control.Concurrent (threadDelay) import Control.Exception (Exception, throw, throwIO) import Control.Monad (mzero, unless, void) -import Control.Monad.Catch (Handler (Handler)) +import Control.Monad.Catch (Handler (Handler), MonadMask) +import Control.Monad.IO.Class (MonadIO, liftIO) import Control.Retry (RetryStatus (..)) import qualified Control.Retry as Retry import Data.Aeson (FromJSON (..), Value (Object), eitherDecode, (.:), (.:?)) import Data.ByteString.Lazy (ByteString, toStrict) +import Data.Hashable (Hashable) import Data.Maybe (fromMaybe) import Data.Text (Text, pack, unpack) import Data.Text.Encoding (decodeUtf8, encodeUtf8) @@ -21,6 +24,7 @@ import qualified Network.HTTP.Client as HTTP import Network.HTTP.Client.TLS (tlsManagerSettings) import Network.HTTP.Types (Status (..)) +import Network.HTTP.Types.Status (statusIsSuccessful) import System.Environment (getEnv) import System.IO (stderr) @@ -65,18 +69,20 @@ doRequest' :: FromJSON a => HTTP.Manager -> HTTP.Request -> IO (Either MatrixError a) doRequest' manager request = do response <- HTTP.httpLbs request manager - case decodeResp (HTTP.responseBody response) of - Nothing -> throwResponseError request response (HTTP.responseBody response) - Just a -> pure a + case decodeResp $ HTTP.responseBody response of + Right x -> pure x + Left e -> if statusIsSuccessful $ HTTP.responseStatus response + then fail e + else throwResponseError request response (HTTP.responseBody response) -decodeResp :: FromJSON a => ByteString -> Maybe (Either MatrixError a) +decodeResp :: FromJSON a => ByteString -> Either String (Either MatrixError a) decodeResp resp = case eitherDecode resp of - Right a -> Just $ pure a - Left _ -> case eitherDecode resp of - Right me -> Just $ Left me - Left _ -> Nothing + Right a -> Right $ pure a + Left e -> case eitherDecode resp of + Right me -> Right $ Left me + Left _ -> Left e -newtype UserID = UserID Text deriving (Show, Eq) +newtype UserID = UserID Text deriving (Show, Eq, Ord, Hashable) instance FromJSON UserID where parseJSON (Object v) = UserID <$> v .: "user_id" @@ -102,11 +108,21 @@ parseJSON _ = mzero -- | 'MatrixIO' is a convenient type alias for server response -type MatrixIO a = IO (Either MatrixError a) +type MatrixIO a = MatrixM IO a --- | Retry 5 times network action, doubling backoff each time -retry' :: Int -> (Text -> IO ()) -> MatrixIO a -> MatrixIO a -retry' limit logRetry action = +type MatrixM m a = m (Either MatrixError a) + +-- | Retry a network action +retryWithLog :: + (MonadMask m, MonadIO m) => + -- | Maximum number of retry + Int -> + -- | A log function, can be used to measure errors + (Text -> m ()) -> + -- | The action to retry + MatrixM m a -> + MatrixM m a +retryWithLog limit logRetry action = Retry.recovering (Retry.exponentialBackoff backoff <> Retry.limitRetries limit) [handler, rateLimitHandler] @@ -118,7 +134,7 @@ Left (MatrixError "M_LIMIT_EXCEEDED" err delayMS) -> do -- Reponse contains a retry_after_ms logRetry $ "RateLimit: " <> err <> " (delay: " <> pack (show delayMS) <> ")" - threadDelay $ fromMaybe 5_000 delayMS * 1000 + liftIO $ threadDelay $ fromMaybe 5_000 delayMS * 1000 throw MatrixRateLimit _ -> pure res @@ -142,4 +158,4 @@ HTTP.InvalidUrlException _ _ -> pure False retry :: MatrixIO a -> MatrixIO a -retry = retry' 7 (hPutStrLn stderr) +retry = retryWithLog 7 (hPutStrLn stderr) diff --git a/src/Network/Matrix/Room.hs b/src/Network/Matrix/Room.hs new file mode 100644 --- /dev/null +++ b/src/Network/Matrix/Room.hs @@ -0,0 +1,35 @@ +{-# LANGUAGE DeriveGeneric #-} +{-# LANGUAGE OverloadedStrings #-} + +-- | Matrix room related data types +module Network.Matrix.Room (RoomCreatePreset (..), RoomCreateRequest (..)) where + +import Data.Aeson (ToJSON (..), Value (..), genericToJSON) +import qualified Data.Aeson as Aeson +import Data.Aeson.Casing (aesonPrefix, snakeCase) +import Data.Text (Text) +import GHC.Generics (Generic) + +-- | https://matrix.org/docs/spec/client_server/latest#post-matrix-client-r0-createroom +data RoomCreatePreset + = PrivateChat + | TrustedPrivateChat + | PublicChat + deriving (Eq, Show) + +instance ToJSON RoomCreatePreset where + toJSON preset = String $ case preset of + PrivateChat -> "private_chat" + TrustedPrivateChat -> "trusted_private_chat" + PublicChat -> "public_chat" + +data RoomCreateRequest = RoomCreateRequest + { rcrPreset :: RoomCreatePreset, + rcrRoomAliasName :: Text, + rcrName :: Text, + rcrTopic :: Text + } + deriving (Eq, Show, Generic) + +instance ToJSON RoomCreateRequest where + toJSON = genericToJSON $ (aesonPrefix snakeCase) {Aeson.omitNothingFields = True} diff --git a/src/Network/Matrix/Tutorial.hs b/src/Network/Matrix/Tutorial.hs --- a/src/Network/Matrix/Tutorial.hs +++ b/src/Network/Matrix/Tutorial.hs @@ -22,6 +22,9 @@ -- * Create a session -- $session + -- * Get messages + -- $sync + -- * Lookup identity -- $identity ) @@ -47,15 +50,55 @@ -- > getTokenOwner :: ClientSession -> MatrixIO WhoAmI -- $session --- Most functions require 'ClientSession' which carries the +-- Most functions require 'Network.Matrix.Client.ClientSession' which carries the -- endpoint url and the http client manager. -- --- The only way to get the client is through the 'Client.createSession' function: +-- The only way to get the client is through the 'Network.Matrix.Client.createSession' function: -- -- > > token <- getTokenFromEnv "MATRIX_TOKEN" -- > > sess <- createSession "https://matrix.org" token -- > > getTokenOwner sess -- > Right (WhoAmI "@tristanc_:matrix.org") + +-- $sync +-- Create a filter to limit the sync result using the 'Network.Matrix.Client.createFilter' function. +-- To keep room message only, use the 'Network.Matrix.Client.messageFilter' default filter: +-- +-- > > Right userId <- getTokenOwner sess +-- > > Right filterId <- createFilter sess userId messageFilter +-- > > getFilter sess (UserID "@gerritbot:matrix.org") filterId +-- > Right (Filter {filterEventFields = ...}) +-- +-- Call the 'Network.Matrix.Client.sync' function to synchronize your client state: +-- +-- > > Right syncResult <- sync sess (Just filterId) Nothing (Just Online) Nothing +-- > > putStrLn $ take 512 $ show (getTimelines syncResult) +-- > SyncResult {srNextBatch = ...} +-- +-- Get next batch with a 300 second timeout using the @since@ argument: +-- +-- > > Right syncResult' <- sync sess (Just filterId) (Just (srNextBatch syncResult)) (Just Online) (Just 300000) +-- +-- Here are some helpers function to format the messages from sync results, copy them in your REPL: +-- +-- > > import qualified Data.Text.IO as Text +-- > > :{ +-- > let printEvent re = Text.putStrLn $ case reContent re of +-- > EventRoomMessage (RoomMessageText mt) -> unAuthor (reSender re) <> ": " <> mtBody mt +-- > _ -> "" +-- > :} +-- > > let printRoomEvent room event = Text.putStr room >> putStr "| " >> printEvent event +-- > > let printRoomEvents (RoomID room, events) = traverse (printRoomEvent room) events +-- > > let printTimelines sr = mapM_ printRoomEvents (getTimelines sr) +-- > > printTimelines syncResult +-- > ... +-- +-- Use the 'Network.Matrix.Client.syncPoll' utility function to continuously get events, +-- here is an example to print new messages, similar to a @tail -f@ process: +-- +-- > > syncPoll sess (Just filterId) (Just (srNextBatch syncResult)) (Just Online) printTimelines +-- > room1| test-user: Hello world! +-- > ... -- $identity -- To use the Identity api you need another token. Get it by running these commands: diff --git a/test/Doctest.hs b/test/Doctest.hs deleted file mode 100644 --- a/test/Doctest.hs +++ /dev/null @@ -1,6 +0,0 @@ -module Main (main) where - -import Test.DocTest - -main :: IO () -main = doctest ["src/", "-XOverloadedStrings"] diff --git a/test/Spec.hs b/test/Spec.hs --- a/test/Spec.hs +++ b/test/Spec.hs @@ -6,28 +6,92 @@ import Control.Monad (void) import qualified Data.Aeson.Encode.Pretty as Aeson -import Data.Text (Text) +import qualified Data.ByteString.Lazy as BS +import Data.Either (isLeft) +import Data.Text (Text, pack) import Data.Time.Clock.System (SystemTime (..), getSystemTime) import Network.Matrix.Client import Network.Matrix.Internal +import System.Environment (lookupEnv) import Test.Hspec main :: IO () -main = hspec spec +main = do + env <- fmap (fmap pack) <$> traverse lookupEnv ["HOMESERVER_URL", "PRIMARY_TOKEN", "SECONDARY_TOKEN"] + runIntegration <- case env of + [Just url, Just tok1, Just tok2] -> do + sess1 <- createSession url (MatrixToken tok1) + sess2 <- createSession url (MatrixToken tok2) + pure $ integration sess1 sess2 + _ -> do + putStrLn "Skipping integration test" + pure $ pure mempty + hspec (parallel $ spec >> runIntegration) +integration :: ClientSession -> ClientSession -> Spec +integration sess1 sess2 = do + describe "integration tests" $ do + it "create room" $ do + resp <- + createRoom + sess1 + ( RoomCreateRequest + { rcrPreset = PublicChat, + rcrRoomAliasName = "test", + rcrName = "matrix-client-haskell-test", + rcrTopic = "Testing matrix-client-haskell" + } + ) + case resp of + Left err -> meError err `shouldBe` "Alias already exists" + Right (RoomID roomID) -> roomID `shouldSatisfy` (/= mempty) + it "join room" $ do + resp <- joinRoom sess1 "#test:localhost" + case resp of + Left err -> error (show err) + Right (RoomID roomID) -> roomID `shouldSatisfy` (/= mempty) + resp' <- joinRoom sess2 "#test:localhost" + case resp' of + Left err -> error (show err) + Right (RoomID roomID) -> roomID `shouldSatisfy` (/= mempty) + it "send message and reply" $ do + -- Flush previous events + Right sr <- sync sess2 Nothing Nothing Nothing Nothing + Right [room] <- getJoinedRooms sess1 + let msg body = RoomMessageText $ MessageText body TextType Nothing Nothing + let since = srNextBatch sr + Right eventID <- sendMessage sess1 room (EventRoomMessage $ msg "Hello") (TxnID since) + Right reply <- sendMessage sess2 room (EventRoomReply eventID $ msg "Hi!") (TxnID since) + reply `shouldNotBe` eventID + spec :: Spec spec = describe "unit tests" $ do it "decode unknown" $ - (decodeResp "" :: Maybe (Either MatrixError String)) - `shouldBe` Nothing + (decodeResp "" :: Either String (Either MatrixError String)) + `shouldSatisfy` isLeft it "decode error" $ - (decodeResp "{\"errcode\": \"TEST\", \"error\":\"a error\"}" :: Maybe (Either MatrixError String)) - `shouldBe` (Just . Left $ MatrixError "TEST" "a error" Nothing) + (decodeResp "{\"errcode\": \"TEST\", \"error\":\"a error\"}" :: Either String (Either MatrixError String)) + `shouldBe` (Right . Left $ MatrixError "TEST" "a error" Nothing) it "decode response" $ decodeResp "{\"user_id\": \"@tristanc_:matrix.org\"}" - `shouldBe` (Just . Right $ UserID "@tristanc_:matrix.org") + `shouldBe` (Right . Right $ UserID "@tristanc_:matrix.org") + it "decode reply" $ do + resp <- decodeResp <$> BS.readFile "test/data/message-reply.json" + case resp of + Right (Right (EventRoomReply eventID (RoomMessageText message))) -> do + eventID `shouldBe` EventID "$eventID" + mtBody message `shouldBe` "> <@tristanc_:matrix.org> :hello\n\nHello there!" + _ -> error $ show resp + it "decode edit" $ do + resp <- decodeResp <$> BS.readFile "test/data/message-edit.json" + case resp of + Right (Right (EventRoomEdit (eventID, RoomMessageText srcMsg) (RoomMessageText message))) -> do + eventID `shouldBe` EventID "$eventID" + mtBody srcMsg `shouldBe` " * > :typo" + mtBody message `shouldBe` "> :hello" + _ -> error $ show resp it "encode room message" $ - encodePretty (RoomMessageText (MessageText "Hello" Nothing Nothing)) + encodePretty (RoomMessageText (MessageText "Hello" TextType Nothing Nothing)) `shouldBe` "{\"body\":\"Hello\",\"msgtype\":\"m.text\"}" it "does not retry on success" $ checkPause (<=) $ do @@ -42,7 +106,7 @@ it "retry on rate limit failure" $ checkPause (>=) $ do let resp = Left $ MatrixError "M_LIMIT_EXCEEDED" "error" (Just 1000) - (retry' 1 (const $ pure ()) (pure resp) :: MatrixIO Int) + (retryWithLog 1 (const $ pure ()) (pure resp) :: MatrixIO Int) `shouldThrow` rateLimitSelector where rateLimitSelector :: MatrixException -> Bool diff --git a/test/data/message-edit.json b/test/data/message-edit.json new file mode 100644 --- /dev/null +++ b/test/data/message-edit.json @@ -0,0 +1,16 @@ +{ + "body": " * > :typo", + "format": "org.matrix.custom.html", + "formatted_body": " *
\n:typo\n
\n", + "m.new_content": { + "body": "> :hello", + "format": "org.matrix.custom.html", + "formatted_body": "
\n:hello\n
\n", + "msgtype": "m.text" + }, + "m.relates_to": { + "event_id": "$eventID", + "rel_type": "m.replace" + }, + "msgtype": "m.text" +} diff --git a/test/data/message-reply.json b/test/data/message-reply.json new file mode 100644 --- /dev/null +++ b/test/data/message-reply.json @@ -0,0 +1,11 @@ +{ + "body": "> <@tristanc_:matrix.org> :hello\n\nHello there!", + "format": "org.matrix.custom.html", + "formatted_body": "
In reply to @tristanc_:matrix.org
:hello
Hello there!", + "m.relates_to": { + "m.in_reply_to": { + "event_id": "$eventID" + } + }, + "msgtype": "m.text" +}