diff --git a/CHANGELOG.md b/CHANGELOG.md --- a/CHANGELOG.md +++ b/CHANGELOG.md @@ -1,5 +1,9 @@ # Changelog +## 0.1.6.1 + +- Use Unpadded base64 encoding, as it was done in v0.1.5.0 + ## 0.1.6.0 - Support base64-1.0 diff --git a/matrix-client.cabal b/matrix-client.cabal --- a/matrix-client.cabal +++ b/matrix-client.cabal @@ -1,87 +1,100 @@ -cabal-version: 2.4 -name: matrix-client -version: 0.1.6.0 -synopsis: A matrix client library +cabal-version: 2.4 +name: matrix-client +version: 0.1.6.1 +synopsis: A matrix client library description: - Matrix client is a library to interface with https://matrix.org. - . - Use this library to interact with matrix server. - . - 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 -license-file: LICENSE -author: Tristan de Cacqueray -maintainer: tdecacqu@redhat.com -copyright: 2021 Red Hat -category: Network -build-type: Simple -extra-doc-files: CHANGELOG.md -extra-source-files: test/data/*.json -tested-with: GHC == 9.6.6 + Matrix client is a library to interface with https://matrix.org. + . + Use this library to interact with matrix server. + . + 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 +license-file: LICENSE +author: Tristan de Cacqueray +maintainer: tdecacqu@redhat.com +copyright: 2021 Red Hat +category: Network +build-type: Simple +extra-doc-files: CHANGELOG.md +extra-source-files: test/data/*.json +tested-with: ghc ==9.6.6 + source-repository head - type: git - location: https://github.com/softwarefactory-project/matrix-client-haskell.git + type: git + location: https://github.com/softwarefactory-project/matrix-client-haskell.git 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 && < 3 - ghc-options: -Wall - -Wcompat - -Widentities - -Wincomplete-uni-patterns - -Wincomplete-record-updates - -Wredundant-constraints - --write-ghc-environment-files=always - if impl(ghc >= 8.2) - ghc-options: -fhide-source-paths - if impl(ghc >= 8.4) - ghc-options: -Wmissing-export-lists + build-depends: + aeson >=1.0.0.0 && <3, + aeson-casing >=0.2.0.0 && <0.3.0.0, + base >=4.11.0.0 && <5, - default-language: Haskell2010 + ghc-options: + -Wall + -Wcompat + -Widentities + -Wincomplete-uni-patterns + -Wincomplete-record-updates + -Wredundant-constraints + --write-ghc-environment-files=always + if impl(ghc >=8.2) + ghc-options: -fhide-source-paths + + if impl(ghc >=8.4) + ghc-options: -Wmissing-export-lists + default-language: Haskell2010 + common lib-depends - build-depends: SHA ^>= 1.6 - , base64 >= 1.0 - , bytestring >= 0.11.3 && < 0.13 - , containers >= 0.6.5 && < 0.8 - , exceptions >= 0.10.4 && < 0.11 - , hashable >= 1.4.0 && < 1.5 - , http-client >= 0.5.0 && < 0.8 - , http-client-tls >= 0.2.0 && < 0.4 - , http-types >= 0.10.0 && < 0.13 - , network-uri >= 2.6.4 && < 2.7 - , profunctors >= 5.6.2 && < 5.7 - , retry >= 0.8 && < 0.10 - , text >= 0.11.1.0 && < 3 - , time >= 1.11.1 && < 1.13 - , unordered-containers >= 0.2.17 && < 0.3 + build-depends: + SHA ^>=1.6, + base64 >=1.0 && <2, + bytestring >=0.11.3 && <0.13, + containers >=0.6.5 && <0.8, + exceptions >=0.10.4 && <0.11, + hashable >=1.4.0 && <1.5, + http-client >=0.5.0 && <0.8, + http-client-tls >=0.2.0 && <0.4, + http-types >=0.10.0 && <0.13, + network-uri >=2.6.4 && <2.7, + profunctors >=5.6.2 && <5.7, + retry >=0.8 && <0.10, + text >=0.11.1.0 && <3, + time >=1.11.1 && <1.13, + unordered-containers >=0.2.17 && <0.3, library - import: common-options, lib-depends - hs-source-dirs: src - exposed-modules: Network.Matrix.Client - , Network.Matrix.Client.Lens - , Network.Matrix.Identity - , Network.Matrix.Tutorial - other-modules: Network.Matrix.Events - , Network.Matrix.Internal - , Network.Matrix.Room + import: common-options, lib-depends + hs-source-dirs: src + exposed-modules: + Network.Matrix.Client + Network.Matrix.Client.Lens + Network.Matrix.Identity + Network.Matrix.Tutorial + other-modules: + Network.Matrix.Events + Network.Matrix.Internal + Network.Matrix.Room + test-suite unit - import: common-options, lib-depends - type: exitcode-stdio-1.0 - hs-source-dirs: test, src - main-is: Spec.hs - build-depends: base - , bytestring - , aeson-pretty - , hspec >= 2 - , matrix-client - , text + import: common-options, lib-depends + type: exitcode-stdio-1.0 + hs-source-dirs: + test + src + + main-is: Spec.hs + build-depends: + aeson-pretty, + base, + bytestring, + hspec >=2, + matrix-client, + text, 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 @@ -6,1326 +6,1377 @@ {-# LANGUAGE OverloadedStrings #-} {-# LANGUAGE RecordWildCards #-} {-# LANGUAGE ScopedTypeVariables #-} -{-# LANGUAGE TypeApplications #-} -{-# LANGUAGE TupleSections #-} - --- | This module contains the client-server API --- https://matrix.org/docs/spec/client_server/r0.6.1 -module Network.Matrix.Client - ( -- * Client - ClientSession, - LoginCredentials (..), - MatrixToken (..), - Username (..), - DeviceId (..), - InitialDeviceDisplayName (..), - LoginSecret (..), - LoginResponse (..), - getTokenFromEnv, - createSession, - login, - loginToken, - logout, - - -- * API - MatrixM, - MatrixIO, - MatrixError (..), - retry, - retryWithLog, - - -- * User data - UserID (..), - getTokenOwner, - - -- * Room Events - Dir (..), - EventType (..), - MRCreate (..), - MRCanonicalAlias (..), - MRGuestAccess (..), - MRHistoryVisibility (..), - MRName (..), - MRTopic (..), - PaginatedRoomMessages (..), - StateKey (..), - StateEvent (..), - StateContent (..), - getRoomEvent, - getRoomMembers, - getRoomState, - getRoomStateEvent, - getRoomMessages, - redact, - sendRoomStateEvent, - - -- * Room management - RoomCreatePreset (..), - RoomCreateRequest (..), - createRoom, - - -- * Room participation - ResolvedRoomAlias (..), - TxnID (..), - sendMessage, - mkReply, - module Network.Matrix.Events, - setRoomAlias, - setRoomVisibility, - resolveRoomAlias, - deleteRoomAlias, - getRoomAliases, - - -- * Room membership - RoomID (..), - RoomAlias (..), - banUser, - checkRoomVisibility, - forgetRoom, - getJoinedRooms, - getPublicRooms, - getPublicRooms', - inviteToRoom, - joinRoom, - joinRoomById, - leaveRoomById, - kickUser, - knockOnRoom, - unbanUser, - - -- * Filter - EventFormat (..), - EventFilter (..), - defaultEventFilter, - eventFilterAll, - RoomEventFilter (..), - defaultRoomEventFilter, - roomEventFilterAll, - StateFilter (..), - defaultStateFilter, - stateFilterAll, - RoomFilter (..), - defaultRoomFilter, - Filter (..), - defaultFilter, - FilterID (..), - messageFilter, - createFilter, - getFilter, - - -- * Account data - - AccountData(accountDataType), - getAccountData, - getAccountData', - setAccountData, - setAccountData', - - -- * Events - sync, - getTimelines, - syncPoll, - Author (..), - Presence (..), - RoomEvent (..), - RoomSummary (..), - TimelineSync (..), - InvitedRoomSync (..), - JoinedRoomSync (..), - SyncResult (..), - SyncResultRoom (..), - ) -where - -import Control.Monad (mzero) -import Control.Monad.IO.Class (MonadIO(liftIO)) -import Data.Aeson (FromJSON (..), ToJSON (..), Value (Object, String), encode, genericParseJSON, genericToJSON, object, withObject, withText, (.:), (.:?), (.=)) -import qualified Data.Aeson as Aeson -import Data.Aeson.Casing (aesonPrefix, snakeCase) -import Data.Hashable (Hashable) -import Data.List.NonEmpty (NonEmpty (..)) -import Data.Map.Strict (Map, foldrWithKey) -import Data.Maybe (fromMaybe, catMaybes) -import Data.Proxy (Proxy(Proxy)) -import qualified Data.Text as T -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 -import qualified Network.URI as URI -import Data.Coerce -import Data.Bifunctor (bimap) -import Data.List (intersperse) -import Data.Aeson.Types (Parser) -import Control.Applicative -import qualified Data.ByteString as B -import qualified Data.ByteString.Lazy as BL - --- $setup --- >>> import Data.Aeson (decode) - -data LoginCredentials = LoginCredentials - { lUsername :: Username - , lLoginSecret :: LoginSecret - , lBaseUrl :: T.Text - , lDeviceId :: Maybe DeviceId - , lInitialDeviceDisplayName :: Maybe InitialDeviceDisplayName - } - -mkLoginRequest :: LoginCredentials -> IO HTTP.Request -mkLoginRequest LoginCredentials {..} = - mkLoginRequest' lBaseUrl lDeviceId lInitialDeviceDisplayName lUsername lLoginSecret - --- | 'login' allows you to generate a session token. -login :: LoginCredentials -> IO ClientSession -login = fmap fst . loginToken - --- | 'loginToken' allows you to generate a session token and recover the Matrix auth token. -loginToken :: LoginCredentials -> IO (ClientSession, MatrixToken) -loginToken cred = do - req <- mkLoginRequest cred - manager <- mkManager - resp' <- doRequest' manager req - case resp' of - Right LoginResponse {..} -> pure (ClientSession (lBaseUrl cred) (MatrixToken lrAccessToken) manager, (MatrixToken lrAccessToken)) - Left err -> - -- NOTE: There is nothing to recover after a failed login attempt - fail $ show err - -mkLogoutRequest :: ClientSession -> IO HTTP.Request -mkLogoutRequest ClientSession {..} = mkLogoutRequest' baseUrl token - --- | 'logout' allows you to destroy a session token. -logout :: ClientSession -> MatrixIO () -logout session = do - req <- mkLogoutRequest session - doRequestExpectEmptyResponse session "logout" req - --- | The session record, use 'createSession' to create it. -data ClientSession = ClientSession - { baseUrl :: T.Text, - token :: MatrixToken, - manager :: HTTP.Manager - } - --- | 'createSession' creates the session record. -createSession :: - -- | The matrix client-server base url, e.g. "https://matrix.org" - T.Text -> - -- | The user token - MatrixToken -> - IO ClientSession -createSession baseUrl' token' = ClientSession baseUrl' token' <$> mkManager - -mkRequest :: ClientSession -> Bool -> T.Text -> IO HTTP.Request -mkRequest ClientSession {..} = mkRequest' baseUrl token - -doRequest :: FromJSON a => ClientSession -> HTTP.Request -> MatrixIO a -doRequest ClientSession {..} = doRequest' manager - --- | Same as 'doRequest' but expect an empty JSON response @{}@ --- which is converted to an empty Haskell tuple @()@. -doRequestExpectEmptyResponse :: ClientSession -> String -> HTTP.Request -> MatrixIO () -doRequestExpectEmptyResponse sess apiName request = fmap ensureEmptyObject <$> doRequest sess request - where - ensureEmptyObject :: Value -> () - ensureEmptyObject value = case value of - Object xs | xs == mempty -> () - _ -> error $ "Unknown " <> apiName <> " response: " <> show value - --- | 'getTokenOwner' gets information about the owner of a given access token. -getTokenOwner :: ClientSession -> MatrixIO UserID -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 T.Text, - crrID :: Maybe T.Text - } - -instance FromJSON CreateRoomResponse where - parseJSON (Object o) = CreateRoomResponse <$> o .:? "message" <*> o .:? "room_id" - parseJSON _ = mzero - -------------------------------------------------------------------------------- --- Room Event API Calls https://spec.matrix.org/v1.1/client-server-api/#getting-events-for-a-room - -getRoomEvent :: ClientSession -> RoomID -> EventID -> MatrixIO RoomEvent -getRoomEvent session (RoomID rid) (EventID eid) = do - request <- mkRequest session True $ "/_matrix/client/v3/rooms/" <> rid <> "/event/" <> eid - doRequest session request - -data User = User { userDisplayName :: Maybe T.Text, userAvatarUrl :: Maybe T.Text } - deriving Show - -instance FromJSON User where - parseJSON = withObject "User" $ \o -> do - userDisplayName <- o .:? "display_name" - userAvatarUrl <- o .:? "avatar_url" - pure $ User {..} - --- | Unexported newtype to grant us a 'FromJSON' instance. -newtype JoinedUsers = JoinedUsers (Map UserID User) - -instance FromJSON JoinedUsers where - parseJSON = withObject "JoinedUsers" $ \o -> do - users <- o .: "joined" - pure $ JoinedUsers users - --- | This API returns a map of MXIDs to member info objects for --- members of the room. The current user must be in the room for it to --- work. --- https://spec.matrix.org/v1.1/client-server-api/#get_matrixclientv3roomsroomidjoined_members -getRoomMembers :: ClientSession -> RoomID -> MatrixIO (Map UserID User) -getRoomMembers session (RoomID rid) = do - request <- mkRequest session True $ "/_matrix/client/v3/rooms/" <> rid <> "/joined_members" - fmap (fmap coerce) $ doRequest @JoinedUsers session request - -newtype StateKey = StateKey T.Text - deriving stock Show - deriving newtype FromJSON - -newtype EventType = EventType T.Text - deriving stock Show - deriving newtype FromJSON - -data MRCreate = MRCreate { mrcCreator :: UserID, mrcRoomVersion :: Integer } - deriving Show - -instance FromJSON MRCreate where - parseJSON = withObject "RoomCreate" $ \o -> do - mrcCreator <- o .: "creator" - mrcRoomVersion <- o .: "room_version" - pure $ MRCreate {..} - -newtype MRName = MRName { mrnName :: T.Text } - deriving Show - -instance FromJSON MRName where - parseJSON = withObject "RoomName" $ \o -> - MRName <$> (o .: "name") - -newtype MRCanonicalAlias = MRCanonicalAlias { mrcAlias :: T.Text } - deriving Show - -instance FromJSON MRCanonicalAlias where - parseJSON = withObject "RoomCanonicalAlias" $ \o -> - MRCanonicalAlias <$> (o .: "alias") - -newtype MRGuestAccess = MRGuestAccess { mrGuestAccess :: T.Text } - deriving Show - -instance FromJSON MRGuestAccess where - parseJSON = withObject "GuestAccess" $ \o -> - MRGuestAccess <$> (o .: "guest_access") - -newtype MRHistoryVisibility = MRHistoryVisibility { mrHistoryVisibility :: T.Text } - deriving Show - -instance FromJSON MRHistoryVisibility where - parseJSON = withObject "HistoryVisibility" $ \o -> - MRHistoryVisibility <$> (o .: "history_visibility") - -newtype MRTopic = MRTopic { mrTopic :: T.Text } - deriving Show - -instance FromJSON MRTopic where - parseJSON = withObject "RoomTopic" $ \o -> - MRTopic <$> (o .: "topic") - -data StateContent = - StRoomCreate MRCreate - -- | StRoomMember MRMember - -- | StRoomPowerLevels MRPowerLevels - -- | StRoomJoinRules MRJoinRules - | StRoomCanonicalAlias MRCanonicalAlias - | StRoomGuestAccess MRGuestAccess - | StRoomHistoryVisibility MRHistoryVisibility - | StRoomName MRName - | StRoomTopic MRTopic - | StOther Value - --- | StSpaceParent MRSpaceParent - deriving Show - -pStRoomCreate :: Value -> Parser StateContent -pStRoomCreate v = StRoomCreate <$> parseJSON v - -pStRoomCanonicAlias :: Value -> Parser StateContent -pStRoomCanonicAlias v = StRoomCanonicalAlias <$> parseJSON v - -pStRoomGuestAccess :: Value -> Parser StateContent -pStRoomGuestAccess v = StRoomGuestAccess <$> parseJSON v - -pStRoomHistoryVisibility :: Value -> Parser StateContent -pStRoomHistoryVisibility v = StRoomHistoryVisibility <$> parseJSON v - -pStRoomName :: Value -> Parser StateContent -pStRoomName v = StRoomName <$> parseJSON v - -pStRoomTopic :: Value -> Parser StateContent -pStRoomTopic v = StRoomTopic <$> parseJSON v - -pStRoomOther :: Value -> Parser StateContent -pStRoomOther v = StOther <$> parseJSON v - -instance FromJSON StateContent where - parseJSON v = - pStRoomCreate v - <|> pStRoomCanonicAlias v - <|> pStRoomGuestAccess v - <|> pStRoomHistoryVisibility v - <|> pStRoomName v - <|> pStRoomTopic v - <|> pStRoomOther v - --- TODO(SOLOMON): Should This constructor be in 'Event'? -data StateEvent = StateEvent - { seContent :: StateContent - , seEventId :: EventID - , seOriginServerTimestamp :: Integer - , sePreviousContent :: Maybe Value - , seRoomId :: RoomID - , seSender :: UserID - , seStateKey :: StateKey - , seEventType :: EventType - , seUnsigned :: Maybe Value - } deriving Show - -instance FromJSON StateEvent where - parseJSON = withObject "StateEvent" $ \o -> do - seContent <- o .: "content" - seEventId <- fmap EventID $ o .: "event_id" - seOriginServerTimestamp <- o .: "origin_server_ts" - sePreviousContent <- o .:? "previous_content" - seRoomId <- fmap RoomID $ o .: "room_id" - seSender <- fmap UserID $ o .: "sender" - seStateKey <- o .: "state_key" - seEventType <- o .: "type" - seUnsigned <- o .:? "unsigned" - pure $ StateEvent {..} - --- | Get the state events for the current state of a room. --- https://spec.matrix.org/v1.1/client-server-api/#get_matrixclientv3roomsroomidstate -getRoomState :: ClientSession -> RoomID -> MatrixIO [StateEvent] -getRoomState session (RoomID rid) = do - request <- mkRequest session True $ "/_matrix/client/v3/rooms/" <> rid <> "/state" - doRequest session request - --- | Looks up the contents of a state event in a room. If the user is --- joined to the room then the state is taken from the current state --- of the room. If the user has left the room then the state is taken --- from the state of the room when they left. --- https://spec.matrix.org/v1.1/client-server-api/#get_matrixclientv3roomsroomidstateeventtypestatekey -getRoomStateEvent :: ClientSession -> RoomID -> EventType -> StateKey -> MatrixIO StateEvent -getRoomStateEvent session (RoomID rid) (EventType et) (StateKey key) = do - request <- mkRequest session True $ "/_matrix/client/v3/rooms/" <> rid <> "/state" <> et <> "/" <> key - doRequest session request - -data Dir - = -- | Forward - F - | -- | Backward - B - -renderDir :: Dir -> B.ByteString -renderDir F = "f" -renderDir B = "b" - -data PaginatedRoomMessages = PaginatedRoomMessages - { chunk :: [RoomEvent] - , end :: Maybe T.Text - -- ^ A token corresponding to the end of chunk. - , start :: T.Text - -- ^ A token corresponding to the start of chunk. - , state :: [StateEvent] - -- ^ A list of state events relevant to showing the chunk. - } deriving Show - -instance FromJSON PaginatedRoomMessages where - parseJSON = withObject "PaginatedRoomMessages" $ \o -> do - chunk <- o .: "chunk" - end <- o .:? "end" - start <- o .: "start" - state <- fmap (fromMaybe []) $ o .:? "state" - pure $ PaginatedRoomMessages {..} - -getRoomMessages :: - ClientSession -> - -- | The room to get events from. - RoomID -> - -- | The direction to return events from. - Dir -> - -- | A 'RoomEventFilter' to filter returned events with. - Maybe RoomEventFilter -> - -- | The Since value to start returning events from. - T.Text -> - -- | The maximum number of events to return. Default: 10. - Maybe Int -> - -- | The token to stop returning events at. - Maybe Int -> - MatrixIO PaginatedRoomMessages -getRoomMessages session (RoomID rid) dir roomFilter fromToken limit toToken = do - request <- mkRequest session True $ "/_matrix/client/v3/rooms/" <> rid <> "/messages" - let dir' = "dir=" <> renderDir dir - filter' = BL.toStrict . mappend "filter=" . encode <$> roomFilter - from' = encodeUtf8 $ "from=" <> fromToken - limit' = BL.toStrict . mappend "limit=" . encode <$> limit - to' = BL.toStrict . mappend "from=" . encode <$> toToken - queryString = mappend "?" $ mconcat $ intersperse "&" $ [dir', from' ] <> catMaybes [to', limit', filter'] - doRequest session $ request { HTTP.queryString = queryString } - --- | Send arbitrary state events to a room. These events will be overwritten if --- , and all match. --- https://spec.matrix.org/v1.1/client-server-api/#put_matrixclientv3roomsroomidstateeventtypestatekey -sendRoomStateEvent :: ClientSession -> RoomID -> EventType -> StateKey -> Value -> MatrixIO EventID -sendRoomStateEvent session (RoomID rid) (EventType et) (StateKey key) event = do - request <- mkRequest session True $ "/_matrix/client/v3/rooms/" <> escapeUriComponent rid <> "/state/" <> escapeUriComponent et <> "/" <> escapeUriComponent key - doRequest session $ - request { HTTP.method = "PUT" - , HTTP.requestBody = HTTP.RequestBodyLBS $ encode event - } - -newtype TxnID = TxnID T.Text deriving (Show, Eq) - --- | This endpoint is used to send a message event to a room. --- https://spec.matrix.org/v1.1/client-server-api/#put_matrixclientv3roomsroomidsendeventtypetxnid -sendMessage :: ClientSession -> RoomID -> Event -> TxnID -> MatrixIO EventID -sendMessage session (RoomID roomId) event (TxnID txnId) = do - request <- mkRequest session True path - doRequest - session - ( request - { HTTP.method = "PUT", - HTTP.requestBody = HTTP.RequestBodyLBS $ encode event - } - ) - where - path = "/_matrix/client/r0/rooms/" <> roomId <> "/send/" <> eventId <> "/" <> txnId - eventId = eventType event - -redact :: ClientSession -> RoomID -> EventID -> TxnID -> T.Text -> MatrixIO EventID -redact session (RoomID rid) (EventID eid) (TxnID txnid) reason = do - request <- mkRequest session True $ "/_matrix/client/v3/rooms/" <> rid <> "/redact/" <> eid <> "/" <> txnid - let body = object ["reason" .= String reason] - doRequest session $ - request { HTTP.method = "PUT" - , HTTP.requestBody = HTTP.RequestBodyLBS $ encode body - } - -------------------------------------------------------------------------------- --- Room API Calls https://spec.matrix.org/v1.1/client-server-api/#rooms-1 - --- | Create a new room with various configuration options. --- https://spec.matrix.org/v1.1/client-server-api/#post_matrixclientv3createroom -createRoom :: ClientSession -> RoomCreateRequest -> MatrixIO RoomID -createRoom session rcr = do - request <- mkRequest session True "/_matrix/client/v3/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 "UNKNOWN" "" Nothing - -newtype RoomAlias = RoomAlias T.Text deriving (Show, Eq, Ord, Hashable) - -data ResolvedRoomAlias = ResolvedRoomAlias - { roomAlias :: RoomAlias - , roomID :: RoomID - -- ^ The room ID for this room alias. - , servers :: [T.Text] - -- ^ A list of servers that are aware of this room alias. - } deriving Show - --- | Boilerplate data type for an aeson instance -data RoomAliasMetadata = RoomAliasMetadata - { ramRoomID :: RoomID - , ramServers :: [T.Text] - } - -instance FromJSON RoomAliasMetadata where - parseJSON = withObject "ResolvedRoomAlias" $ \o -> do - ramRoomID <- fmap RoomID $ o .: "room_id" - ramServers <- o .: "servers" - pure $ RoomAliasMetadata {..} - --- | Requests that the server resolve a room alias to a room ID. --- https://spec.matrix.org/v1.1/client-server-api/#get_matrixclientv3directoryroomroomalias -resolveRoomAlias :: ClientSession -> RoomAlias -> MatrixIO ResolvedRoomAlias -resolveRoomAlias session r@(RoomAlias alias) = do - request <- mkRequest session True $ "/_matrix/client/v3/directory/room/" <> escapeUriComponent alias - resp <- doRequest session $ request { HTTP.method = "GET" } - case resp of - Left err -> pure $ Left err - Right RoomAliasMetadata {..} -> pure $ Right $ ResolvedRoomAlias r ramRoomID ramServers - --- | Create a mapping of room alias to room ID. --- https://spec.matrix.org/v1.1/client-server-api/#put_matrixclientv3directoryroomroomalias -setRoomAlias :: ClientSession -> RoomAlias -> RoomID -> MatrixIO () -setRoomAlias session (RoomAlias alias) (RoomID roomId)= do - request <- mkRequest session True $ "/_matrix/client/v3/directory/room/" <> escapeUriComponent alias - doRequestExpectEmptyResponse session "set room alias" $ - request { HTTP.method = "PUT" - , HTTP.requestBody = HTTP.RequestBodyLBS $ encode $ object [("room_id" .= roomId)] - } - --- | Delete a mapping of room alias to room ID. --- https://spec.matrix.org/v1.1/client-server-api/#delete_matrixclientv3directoryroomroomalias -deleteRoomAlias :: ClientSession -> RoomAlias -> MatrixIO () -deleteRoomAlias session (RoomAlias alias) = do - request <- mkRequest session True $ "/_matrix/client/v3/directory/room/" <> escapeUriComponent alias - doRequestExpectEmptyResponse session "delete room alias" $ request { HTTP.method = "DELETE" } - -data ResolvedAliases = ResolvedAliases [RoomAlias] - -instance FromJSON ResolvedAliases where - parseJSON = withObject "ResolvedAliases" $ \o -> do - aliases <- o .: "aliases" - pure $ ResolvedAliases (RoomAlias <$> aliases) - --- | Get a list of aliases maintained by the local server for the given room. --- https://spec.matrix.org/v1.1/client-server-api/#get_matrixclientv3roomsroomidaliases -getRoomAliases :: ClientSession -> RoomID -> MatrixIO [RoomAlias] -getRoomAliases session (RoomID rid) = do - request <- mkRequest session True $ "/_matrix/client/v3/rooms/" <> rid <> "/aliases" - resp <- doRequest - session $ - request { HTTP.method = "GET" } - case resp of - Left err -> pure $ Left err - Right (ResolvedAliases aliases) -> pure $ Right aliases --- | A newtype wrapper to decoded nested list --- --- >>> decode "{\"joined_rooms\": [\"!foo:example.com\"]}" :: Maybe JoinedRooms --- Just (JoinedRooms {unRooms = [RoomID "!foo:example.com"]}) -newtype JoinedRooms = JoinedRooms {unRooms :: [RoomID]} deriving (Show) - -instance FromJSON JoinedRooms where - parseJSON (Object v) = do - rooms <- v .: "joined_rooms" - pure . JoinedRooms $ RoomID <$> rooms - parseJSON _ = mzero - --- | Returns a list of the user’s current rooms. --- https://spec.matrix.org/v1.1/client-server-api/#get_matrixclientv3joined_rooms -getJoinedRooms :: ClientSession -> MatrixIO [RoomID] -getJoinedRooms session = do - request <- mkRequest session True "/_matrix/client/r0/joined_rooms" - response <- doRequest session request - pure $ unRooms <$> response - -newtype RoomID = RoomID T.Text deriving (Show, Eq, Ord, Hashable) - -instance FromJSON RoomID where - parseJSON (Object v) = RoomID <$> v .: "room_id" - parseJSON _ = mzero - --- | Invites a user to participate in a particular room. They do not --- start participating in the room until they actually join the room. --- https://spec.matrix.org/v1.1/client-server-api/#post_matrixclientv3roomsroomidinvite -inviteToRoom :: ClientSession -> RoomID -> UserID -> Maybe T.Text -> MatrixIO () -inviteToRoom session (RoomID rid) (UserID uid) reason = do - request <- mkRequest session True $ "/_matrix/client/v3/rooms/" <> rid <> "/invite" - let body = object $ [("user_id", toJSON uid)] <> catMaybes [fmap (("reason",) . toJSON) reason] - doRequestExpectEmptyResponse session "invite" $ - request { HTTP.method = "POST" - , HTTP.requestBody = HTTP.RequestBodyLBS $ encode body - } - --- | Note that this API takes either a room ID or alias, unlike 'joinRoomById' --- https://spec.matrix.org/v1.1/client-server-api/#post_matrixclientv3joinroomidoralias -joinRoom :: ClientSession -> T.Text -> MatrixIO RoomID -joinRoom session roomName = do - request <- mkRequest session True $ "/_matrix/client/r0/join/" <> roomNameUrl - doRequest session (request {HTTP.method = "POST"}) - where - roomNameUrl = decodeUtf8 . urlEncode True . encodeUtf8 $ roomName - --- | Starts a user participating in a particular room, if that user is --- allowed to participate in that room. --- https://spec.matrix.org/v1.1/client-server-api/#post_matrixclientv3roomsroomidjoin -joinRoomById :: ClientSession -> RoomID -> MatrixIO RoomID -joinRoomById session (RoomID roomId) = do - request <- mkRequest session True $ "/_matrix/client/r0/rooms/" <> roomId <> "/join" - doRequest session (request {HTTP.method = "POST"}) - --- | This API “knocks” on the room to ask for permission to join, if --- the user is allowed to knock on the room. --- https://spec.matrix.org/v1.1/client-server-api/#post_matrixclientv3knockroomidoralias -knockOnRoom :: ClientSession -> Either RoomID RoomAlias -> [T.Text] -> Maybe T.Text -> MatrixIO RoomID -knockOnRoom session room servers reason = do - request <- mkRequest session True $ " /_matrix/client/v3/knock/" <> indistinct (bimap coerce coerce room) - let body = object $ catMaybes [fmap (("reason",) . toJSON) reason] - doRequest session $ - request { HTTP.method = "POST" - , HTTP.requestBody = HTTP.RequestBodyLBS $ encode body - , HTTP.queryString = encodeUtf8 $ "?server_name=" <> mconcat (intersperse "," servers) - } - --- | Stops remembering a particular room. --- https://spec.matrix.org/v1.1/client-server-api/#post_matrixclientv3roomsroomidforget -forgetRoom :: ClientSession -> RoomID -> MatrixIO () -forgetRoom session (RoomID roomId) = do - request <- mkRequest session True $ "/_matrix/client/v3/rooms/" <> roomId <> "/forget" - doRequestExpectEmptyResponse session "forget" (request {HTTP.method = "POST"}) - --- | Stop participating in a particular room. --- https://spec.matrix.org/v1.1/client-server-api/#post_matrixclientv3roomsroomidleave -leaveRoomById :: ClientSession -> RoomID -> MatrixIO () -leaveRoomById session (RoomID roomId) = do - request <- mkRequest session True $ "/_matrix/client/r0/rooms/" <> roomId <> "/leave" - doRequestExpectEmptyResponse session "leave" (request {HTTP.method = "POST"}) - --- | Kick a user from the room. --- https://spec.matrix.org/v1.1/client-server-api/#post_matrixclientv3roomsroomidkick -kickUser :: ClientSession -> RoomID -> UserID -> Maybe T.Text -> MatrixIO () -kickUser session (RoomID roomId) (UserID uid) reason = do - request <- mkRequest session True $ "/_matrix/client/v3/rooms/" <> roomId <> "/kick" - let body = object $ [("user_id", toJSON uid)] <> catMaybes [fmap (("reason",) . toJSON) reason] - doRequestExpectEmptyResponse session "kick" $ - request { HTTP.method = "POST" - , HTTP.requestBody = HTTP.RequestBodyLBS $ encode body - } - --- | Ban a user in the room. If the user is currently in the room, also kick them. --- https://spec.matrix.org/v1.1/client-server-api/#post_matrixclientv3roomsroomidban -banUser :: ClientSession -> RoomID -> UserID -> Maybe T.Text -> MatrixIO () -banUser session (RoomID roomId) (UserID uid) reason = do - request <- mkRequest session True $ "/_matrix/client/v3/rooms/" <> roomId <> "/ban" - let body = object $ [("user_id", toJSON uid)] <> catMaybes [fmap (("reason",) . toJSON) reason] - doRequestExpectEmptyResponse session "ban" $ - request { HTTP.method = "POST" - , HTTP.requestBody = HTTP.RequestBodyLBS $ encode body - } - --- | Unban a user from the room. This allows them to be invited to the --- room, and join if they would otherwise be allowed to join according --- to its join rules. --- https://spec.matrix.org/v1.1/client-server-api/#post_matrixclientv3roomsroomidunban -unbanUser :: ClientSession -> RoomID -> UserID -> Maybe T.Text -> MatrixIO () -unbanUser session (RoomID roomId) (UserID uid) reason = do - request <- mkRequest session True $ "/_matrix/client/v3/rooms/" <> roomId <> "/unban" - let body = object $ [("user_id", toJSON uid)] <> catMaybes [fmap (("reason",) . toJSON) reason] - doRequestExpectEmptyResponse session "unban" $ - request { HTTP.method = "POST" - , HTTP.requestBody = HTTP.RequestBodyLBS $ encode body - } - -data Visibility = Public | Private - deriving (Show) - -instance ToJSON Visibility where - toJSON = \case - Public -> String "public" - Private -> String "private" - -instance FromJSON Visibility where - parseJSON = withText "Visibility" $ \case - "public" -> pure Public - "private" -> pure Private - _ -> mzero - -newtype GetVisibility = GetVisibility { getVisibility :: Visibility } - -instance FromJSON GetVisibility where - parseJSON = withObject "GetVisibility" $ \o -> do - getVisibility <- o .: "visibility" - pure $ GetVisibility {..} - --- | Gets the visibility of a given room on the server’s public room directory. --- https://spec.matrix.org/v1.1/client-server-api/#get_matrixclientv3directorylistroomroomid -checkRoomVisibility :: ClientSession -> RoomID -> MatrixIO Visibility -checkRoomVisibility session (RoomID rid) = do - request <- mkRequest session True $ "/_matrix/client/v3/directory/list/room/" <> rid - fmap (fmap getVisibility) $ doRequest session request - --- | Sets the visibility of a given room in the server’s public room directory. --- https://spec.matrix.org/v1.1/client-server-api/#put_matrixclientv3directorylistroomroomid -setRoomVisibility :: ClientSession -> RoomID -> Visibility -> MatrixIO () -setRoomVisibility session (RoomID rid) visibility = do - request <- mkRequest session True $ "/_matrix/client/v3/directory/list/room/" <> rid - let body = object $ [("visibility", toJSON visibility)] - doRequestExpectEmptyResponse session "set room visibility" $ - request { HTTP.method = "PUT" - , HTTP.requestBody = HTTP.RequestBodyLBS $ encode body - } - --- | A pagination token from a previous request, allowing clients to --- get the next (or previous) batch of rooms. The direction of --- pagination is specified solely by which token is supplied, rather --- than via an explicit flag. -newtype PaginationChunk = PaginationChunk { getChunk :: T.Text } - deriving stock (Show) - deriving newtype (ToJSON, FromJSON) - -data Room = Room - { aliases :: Maybe [T.Text] - , avatarUrl :: Maybe T.Text - , canonicalAlias :: Maybe T.Text - , guestCanJoin :: Bool - , joinRule :: Maybe T.Text - , name :: Maybe T.Text - , numJoinedMembers :: Int - , roomId :: RoomID - , topic :: Maybe T.Text - , worldReadable :: Bool - } deriving Show - -instance FromJSON Room where - parseJSON = withObject "Room" $ \o -> do - aliases <- o .:? "aliases" - avatarUrl <- o .:? "avatar_url" - canonicalAlias <- o .:? "canonical_alias" - guestCanJoin <- o .: "guest_can_join" - joinRule <- o .:? "join_rule" - name <- o .:? "name" - numJoinedMembers <- o .: "num_joined_members" - roomId <- fmap RoomID $ o .: "room_id" - topic <- o .:? "topic" - worldReadable <- o .: "world_readable" - pure $ Room {..} - -data PublicRooms = PublicRooms - { prChunk :: [Room] - , prNextBatch :: Maybe PaginationChunk - , prPrevBatch :: Maybe PaginationChunk - , prTotalRoomCountEstimate :: Maybe Int - } deriving Show - -instance FromJSON PublicRooms where - parseJSON = withObject "PublicRooms" $ \o -> do - prChunk <- o .: "chunk" - prNextBatch <- o .:? "next_batch" - prPrevBatch <- o .:? "prev_batch" - prTotalRoomCountEstimate <- o .:? "total_room_count_estimate" - pure $ PublicRooms {..} - --- | Lists the public rooms on the server. --- https://spec.matrix.org/v1.1/client-server-api/#get_matrixclientv3publicrooms -getPublicRooms :: ClientSession -> Maybe Int -> Maybe PaginationChunk -> MatrixIO PublicRooms -getPublicRooms session limit chunk = do - request <- mkRequest session True "/_matrix/client/v3/publicRooms" - let since = fmap (mappend "since=" . getChunk) chunk - limit' = fmap (mappend "limit=" . tshow) limit - queryString = encodeUtf8 $ mconcat $ intersperse "&" $ catMaybes [since, limit'] - doRequest session $ - request { HTTP.queryString = queryString } - -newtype ThirdPartyInstanceId = ThirdPartyInstanceId T.Text - deriving (FromJSON, ToJSON) - --- | Lists the public rooms on the server, with optional filter. --- https://spec.matrix.org/v1.1/client-server-api/#post_matrixclientv3publicrooms -getPublicRooms' :: ClientSession -> Maybe Int -> Maybe PaginationChunk -> Maybe T.Text -> Maybe Bool -> Maybe ThirdPartyInstanceId-> MatrixIO PublicRooms -getPublicRooms' session limit chunk searchTerm includeAllNetworks thirdPartyId = do - request <- mkRequest session True "/_matrix/client/v3/publicRooms" - let filter' = object $ catMaybes [ fmap (("generic_search_term",) . toJSON) searchTerm] - since = fmap (("since",) . toJSON) chunk - limit' = fmap (("limit",) . toJSON) limit - includeAllNetworks' = fmap (("include_all_networks",) . toJSON) includeAllNetworks - thirdPartyId' = fmap (("third_party_instance_id",) . toJSON) thirdPartyId - body = object $ [("filter", filter')] <> catMaybes [ since, limit', includeAllNetworks', thirdPartyId' ] - doRequest session $ - request { HTTP.method = "POST" - , HTTP.requestBody = HTTP.RequestBodyLBS $ encode body - } - -------------------------------------------------------------------------------- --- https://matrix.org/docs/spec/client_server/latest#post-matrix-client-r0-user-userid-filter -newtype FilterID = FilterID T.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 [T.Text], - efNotTypes :: Maybe [T.Text], - efSenders :: Maybe [T.Text], - efTypes :: Maybe [T.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 [T.Text], - refNotTypes :: Maybe [T.Text], - refSenders :: Maybe [T.Text], - refTypes :: Maybe [T.Text], - refLazyLoadMembers :: Maybe Bool, - refIncludeRedundantMembers :: Maybe Bool, - refNotRooms :: Maybe [T.Text], - refRooms :: Maybe [T.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 [T.Text], - sfNotTypes :: Maybe [T.Text], - sfSenders :: Maybe [T.Text], - sfTypes :: Maybe [T.Text], - sfLazyLoadMembers :: Maybe Bool, - sfIncludeRedundantMembers :: Maybe Bool, - sfNotRooms :: Maybe [T.Text], - sfRooms :: Maybe [T.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 [T.Text], - rfRooms :: Maybe [T.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 [T.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 :: T.Text} - deriving (Show, Eq) - deriving newtype (FromJSON, ToJSON) - -data RoomEvent = RoomEvent - { reContent :: Event, - reType :: T.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 T.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 . tshow $ 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 :: T.Text, - srRooms :: Maybe SyncResultRoom - } - deriving (Show, Eq, Generic) - -data SyncResultRoom = SyncResultRoom - { srrJoin :: Maybe (Map T.Text JoinedRoomSync) - , srrInvite :: Maybe (Map T.Text InvitedRoomSync) - } - deriving (Show, Eq, Generic) - -data InvitedRoomSync = InvitedRoomSync - deriving (Show, Eq, Generic) - -unFilterID :: FilterID -> T.Text -unFilterID (FilterID x) = x - -------------------------------------------------------------------------------- --- https://matrix.org/docs/spec/client_server/latest#forming-relationships-between-events - --- | 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 -> T.Text -> T.Text -> T.Text -addReplyBody (Author author) old reply = - let oldLines = T.lines old - headLine = "> <" <> author <> ">" <> maybe "" (mappend " ") (headMaybe oldLines) - newBody = [headLine] <> map (mappend "> ") (tail' oldLines) <> [""] <> [reply] - in T.dropEnd 1 $ T.unlines newBody - -addReplyFormattedBody :: RoomID -> EventID -> Author -> T.Text -> T.Text -> T.Text -addReplyFormattedBody (RoomID roomID) (EventID eventID) (Author author) old reply = - T.unlines - [ "", - "
", - " roomID <> "/" <> eventID <> "\">In reply to", - " author <> "\">" <> author <> "", - "
", - " " <> old, - "
", - "", - reply - ] - --- | Convert body by encoding HTML special char --- --- >>> toFormattedBody "& " --- "& <test>" -toFormattedBody :: T.Text -> T.Text -toFormattedBody = T.concatMap char - where - char x = case x of - '<' -> "<" - '>' -> ">" - '&' -> "&" - _ -> T.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 T.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" (tshow <$> presenceM) - <> toQs "timeout" (tshow <$> 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 T.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 :: T.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 - -getAccountData' :: (FromJSON a) => ClientSession -> UserID -> T.Text -> MatrixIO a -getAccountData' session userID t = - mkRequest session True (accountDataPath userID t) >>= doRequest session - -setAccountData' :: (ToJSON a) => ClientSession -> UserID -> T.Text -> a -> MatrixIO () -setAccountData' session userID t value = do - request <- mkRequest session True $ accountDataPath userID t - doRequestExpectEmptyResponse session "set account data" $ request - { HTTP.method = "PUT" - , HTTP.requestBody = HTTP.RequestBodyLBS $ encode value - } - -accountDataPath :: UserID -> T.Text -> T.Text -accountDataPath (UserID userID) t = - "/_matrix/client/r0/user/" <> userID <> "/account_data/" <> t - -class (FromJSON a, ToJSON a) => AccountData a where - accountDataType :: proxy a -> T.Text - -getAccountData :: forall a. (AccountData a) => ClientSession -> UserID -> MatrixIO a -getAccountData session userID = getAccountData' session userID $ - accountDataType (Proxy :: Proxy a) - -setAccountData :: forall a. (AccountData a) => ClientSession -> UserID -> a -> MatrixIO () -setAccountData session userID = setAccountData' session userID $ - accountDataType (Proxy :: Proxy a) - -------------------------------------------------------------------------------- --- Utils - -headMaybe :: [a] -> Maybe a -headMaybe xs = case xs of - [] -> Nothing - (x : _) -> Just x - -tail' :: [a] -> [a] -tail' xs = case xs of - [] -> [] - (_ : rest) -> rest - -indistinct :: Either x x -> x -indistinct = id `either` id - -tshow :: Show a => a -> T.Text +{-# LANGUAGE TupleSections #-} +{-# LANGUAGE TypeApplications #-} + +{- | This module contains the client-server API +https://matrix.org/docs/spec/client_server/r0.6.1 +-} +module Network.Matrix.Client ( + -- * Client + ClientSession, + LoginCredentials (..), + MatrixToken (..), + Username (..), + DeviceId (..), + InitialDeviceDisplayName (..), + LoginSecret (..), + LoginResponse (..), + getTokenFromEnv, + createSession, + login, + loginToken, + logout, + + -- * API + MatrixM, + MatrixIO, + MatrixError (..), + retry, + retryWithLog, + + -- * User data + UserID (..), + getTokenOwner, + + -- * Room Events + Dir (..), + EventType (..), + MRCreate (..), + MRCanonicalAlias (..), + MRGuestAccess (..), + MRHistoryVisibility (..), + MRName (..), + MRTopic (..), + PaginatedRoomMessages (..), + StateKey (..), + StateEvent (..), + StateContent (..), + getRoomEvent, + getRoomMembers, + getRoomState, + getRoomStateEvent, + getRoomMessages, + redact, + sendRoomStateEvent, + + -- * Room management + RoomCreatePreset (..), + RoomCreateRequest (..), + createRoom, + + -- * Room participation + ResolvedRoomAlias (..), + TxnID (..), + sendMessage, + mkReply, + module Network.Matrix.Events, + setRoomAlias, + setRoomVisibility, + resolveRoomAlias, + deleteRoomAlias, + getRoomAliases, + + -- * Room membership + RoomID (..), + RoomAlias (..), + banUser, + checkRoomVisibility, + forgetRoom, + getJoinedRooms, + getPublicRooms, + getPublicRooms', + inviteToRoom, + joinRoom, + joinRoomById, + leaveRoomById, + kickUser, + knockOnRoom, + unbanUser, + + -- * Filter + EventFormat (..), + EventFilter (..), + defaultEventFilter, + eventFilterAll, + RoomEventFilter (..), + defaultRoomEventFilter, + roomEventFilterAll, + StateFilter (..), + defaultStateFilter, + stateFilterAll, + RoomFilter (..), + defaultRoomFilter, + Filter (..), + defaultFilter, + FilterID (..), + messageFilter, + createFilter, + getFilter, + + -- * Account data + AccountData (accountDataType), + getAccountData, + getAccountData', + setAccountData, + setAccountData', + + -- * Events + sync, + getTimelines, + syncPoll, + Author (..), + Presence (..), + RoomEvent (..), + RoomSummary (..), + TimelineSync (..), + InvitedRoomSync (..), + JoinedRoomSync (..), + SyncResult (..), + SyncResultRoom (..), +) +where + +import Control.Applicative +import Control.Monad (mzero) +import Control.Monad.IO.Class (MonadIO (liftIO)) +import Data.Aeson (FromJSON (..), ToJSON (..), Value (Object, String), encode, genericParseJSON, genericToJSON, object, withObject, withText, (.:), (.:?), (.=)) +import qualified Data.Aeson as Aeson +import Data.Aeson.Casing (aesonPrefix, snakeCase) +import Data.Aeson.Types (Parser) +import Data.Bifunctor (bimap) +import qualified Data.ByteString as B +import qualified Data.ByteString.Lazy as BL +import Data.Coerce +import Data.Hashable (Hashable) +import Data.List (intersperse) +import Data.List.NonEmpty (NonEmpty (..)) +import Data.Map.Strict (Map, foldrWithKey) +import Data.Maybe (catMaybes, fromMaybe) +import Data.Proxy (Proxy (Proxy)) +import qualified Data.Text as T +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 +import qualified Network.URI as URI + +{- $setup +>>> import Data.Aeson (decode) +-} + +data LoginCredentials = LoginCredentials + { lUsername :: Username + , lLoginSecret :: LoginSecret + , lBaseUrl :: T.Text + , lDeviceId :: Maybe DeviceId + , lInitialDeviceDisplayName :: Maybe InitialDeviceDisplayName + } + +mkLoginRequest :: LoginCredentials -> IO HTTP.Request +mkLoginRequest LoginCredentials{..} = + mkLoginRequest' lBaseUrl lDeviceId lInitialDeviceDisplayName lUsername lLoginSecret + +-- | 'login' allows you to generate a session token. +login :: LoginCredentials -> IO ClientSession +login = fmap fst . loginToken + +-- | 'loginToken' allows you to generate a session token and recover the Matrix auth token. +loginToken :: LoginCredentials -> IO (ClientSession, MatrixToken) +loginToken cred = do + req <- mkLoginRequest cred + manager <- mkManager + resp' <- doRequest' manager req + case resp' of + Right LoginResponse{..} -> pure (ClientSession (lBaseUrl cred) (MatrixToken lrAccessToken) manager, MatrixToken lrAccessToken) + Left err -> + -- NOTE: There is nothing to recover after a failed login attempt + fail $ show err + +mkLogoutRequest :: ClientSession -> IO HTTP.Request +mkLogoutRequest ClientSession{..} = mkLogoutRequest' baseUrl token + +-- | 'logout' allows you to destroy a session token. +logout :: ClientSession -> MatrixIO () +logout session = do + req <- mkLogoutRequest session + doRequestExpectEmptyResponse session "logout" req + +-- | The session record, use 'createSession' to create it. +data ClientSession = ClientSession + { baseUrl :: T.Text + , token :: MatrixToken + , manager :: HTTP.Manager + } + +-- | 'createSession' creates the session record. +createSession :: + -- | The matrix client-server base url, e.g. "https://matrix.org" + T.Text -> + -- | The user token + MatrixToken -> + IO ClientSession +createSession baseUrl' token' = ClientSession baseUrl' token' <$> mkManager + +mkRequest :: ClientSession -> Bool -> T.Text -> IO HTTP.Request +mkRequest ClientSession{..} = mkRequest' baseUrl token + +doRequest :: (FromJSON a) => ClientSession -> HTTP.Request -> MatrixIO a +doRequest ClientSession{..} = doRequest' manager + +{- | Same as 'doRequest' but expect an empty JSON response @{}@ +which is converted to an empty Haskell tuple @()@. +-} +doRequestExpectEmptyResponse :: ClientSession -> String -> HTTP.Request -> MatrixIO () +doRequestExpectEmptyResponse sess apiName request = fmap ensureEmptyObject <$> doRequest sess request + where + ensureEmptyObject :: Value -> () + ensureEmptyObject value = case value of + Object xs | xs == mempty -> () + _ -> error $ "Unknown " <> apiName <> " response: " <> show value + +-- | 'getTokenOwner' gets information about the owner of a given access token. +getTokenOwner :: ClientSession -> MatrixIO UserID +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 T.Text + , crrID :: Maybe T.Text + } + +instance FromJSON CreateRoomResponse where + parseJSON (Object o) = CreateRoomResponse <$> o .:? "message" <*> o .:? "room_id" + parseJSON _ = mzero + +------------------------------------------------------------------------------- +-- Room Event API Calls https://spec.matrix.org/v1.1/client-server-api/#getting-events-for-a-room + +getRoomEvent :: ClientSession -> RoomID -> EventID -> MatrixIO RoomEvent +getRoomEvent session (RoomID rid) (EventID eid) = do + request <- mkRequest session True $ "/_matrix/client/v3/rooms/" <> rid <> "/event/" <> eid + doRequest session request + +data User = User {userDisplayName :: Maybe T.Text, userAvatarUrl :: Maybe T.Text} + deriving (Show) + +instance FromJSON User where + parseJSON = withObject "User" $ \o -> do + userDisplayName <- o .:? "display_name" + userAvatarUrl <- o .:? "avatar_url" + pure $ User{..} + +-- | Unexported newtype to grant us a 'FromJSON' instance. +newtype JoinedUsers = JoinedUsers (Map UserID User) + +instance FromJSON JoinedUsers where + parseJSON = withObject "JoinedUsers" $ \o -> do + users <- o .: "joined" + pure $ JoinedUsers users + +{- | This API returns a map of MXIDs to member info objects for +members of the room. The current user must be in the room for it to +work. +https://spec.matrix.org/v1.1/client-server-api/#get_matrixclientv3roomsroomidjoined_members +-} +getRoomMembers :: ClientSession -> RoomID -> MatrixIO (Map UserID User) +getRoomMembers session (RoomID rid) = do + request <- mkRequest session True $ "/_matrix/client/v3/rooms/" <> rid <> "/joined_members" + fmap coerce <$> doRequest @JoinedUsers session request + +newtype StateKey = StateKey T.Text + deriving stock (Show) + deriving newtype (FromJSON) + +newtype EventType = EventType T.Text + deriving stock (Show) + deriving newtype (FromJSON) + +data MRCreate = MRCreate {mrcCreator :: UserID, mrcRoomVersion :: Integer} + deriving (Show) + +instance FromJSON MRCreate where + parseJSON = withObject "RoomCreate" $ \o -> do + mrcCreator <- o .: "creator" + mrcRoomVersion <- o .: "room_version" + pure $ MRCreate{..} + +newtype MRName = MRName {mrnName :: T.Text} + deriving (Show) + +instance FromJSON MRName where + parseJSON = withObject "RoomName" $ \o -> + MRName <$> (o .: "name") + +newtype MRCanonicalAlias = MRCanonicalAlias {mrcAlias :: T.Text} + deriving (Show) + +instance FromJSON MRCanonicalAlias where + parseJSON = withObject "RoomCanonicalAlias" $ \o -> + MRCanonicalAlias <$> (o .: "alias") + +newtype MRGuestAccess = MRGuestAccess {mrGuestAccess :: T.Text} + deriving (Show) + +instance FromJSON MRGuestAccess where + parseJSON = withObject "GuestAccess" $ \o -> + MRGuestAccess <$> (o .: "guest_access") + +newtype MRHistoryVisibility = MRHistoryVisibility {mrHistoryVisibility :: T.Text} + deriving (Show) + +instance FromJSON MRHistoryVisibility where + parseJSON = withObject "HistoryVisibility" $ \o -> + MRHistoryVisibility <$> (o .: "history_visibility") + +newtype MRTopic = MRTopic {mrTopic :: T.Text} + deriving (Show) + +instance FromJSON MRTopic where + parseJSON = withObject "RoomTopic" $ \o -> + MRTopic <$> (o .: "topic") + +data StateContent + = StRoomCreate MRCreate + | -- | StRoomMember MRMember + -- | StRoomPowerLevels MRPowerLevels + -- | StRoomJoinRules MRJoinRules + StRoomCanonicalAlias MRCanonicalAlias + | StRoomGuestAccess MRGuestAccess + | StRoomHistoryVisibility MRHistoryVisibility + | StRoomName MRName + | StRoomTopic MRTopic + | StOther Value + --- | StSpaceParent MRSpaceParent + deriving (Show) + +pStRoomCreate :: Value -> Parser StateContent +pStRoomCreate v = StRoomCreate <$> parseJSON v + +pStRoomCanonicAlias :: Value -> Parser StateContent +pStRoomCanonicAlias v = StRoomCanonicalAlias <$> parseJSON v + +pStRoomGuestAccess :: Value -> Parser StateContent +pStRoomGuestAccess v = StRoomGuestAccess <$> parseJSON v + +pStRoomHistoryVisibility :: Value -> Parser StateContent +pStRoomHistoryVisibility v = StRoomHistoryVisibility <$> parseJSON v + +pStRoomName :: Value -> Parser StateContent +pStRoomName v = StRoomName <$> parseJSON v + +pStRoomTopic :: Value -> Parser StateContent +pStRoomTopic v = StRoomTopic <$> parseJSON v + +pStRoomOther :: Value -> Parser StateContent +pStRoomOther v = StOther <$> parseJSON v + +instance FromJSON StateContent where + parseJSON v = + pStRoomCreate v + <|> pStRoomCanonicAlias v + <|> pStRoomGuestAccess v + <|> pStRoomHistoryVisibility v + <|> pStRoomName v + <|> pStRoomTopic v + <|> pStRoomOther v + +-- TODO(SOLOMON): Should This constructor be in 'Event'? +data StateEvent = StateEvent + { seContent :: StateContent + , seEventId :: EventID + , seOriginServerTimestamp :: Integer + , sePreviousContent :: Maybe Value + , seRoomId :: RoomID + , seSender :: UserID + , seStateKey :: StateKey + , seEventType :: EventType + , seUnsigned :: Maybe Value + } + deriving (Show) + +instance FromJSON StateEvent where + parseJSON = withObject "StateEvent" $ \o -> do + seContent <- o .: "content" + seEventId <- fmap EventID $ o .: "event_id" + seOriginServerTimestamp <- o .: "origin_server_ts" + sePreviousContent <- o .:? "previous_content" + seRoomId <- fmap RoomID $ o .: "room_id" + seSender <- fmap UserID $ o .: "sender" + seStateKey <- o .: "state_key" + seEventType <- o .: "type" + seUnsigned <- o .:? "unsigned" + pure $ StateEvent{..} + +{- | Get the state events for the current state of a room. +https://spec.matrix.org/v1.1/client-server-api/#get_matrixclientv3roomsroomidstate +-} +getRoomState :: ClientSession -> RoomID -> MatrixIO [StateEvent] +getRoomState session (RoomID rid) = do + request <- mkRequest session True $ "/_matrix/client/v3/rooms/" <> rid <> "/state" + doRequest session request + +{- | Looks up the contents of a state event in a room. If the user is +joined to the room then the state is taken from the current state +of the room. If the user has left the room then the state is taken +from the state of the room when they left. +https://spec.matrix.org/v1.1/client-server-api/#get_matrixclientv3roomsroomidstateeventtypestatekey +-} +getRoomStateEvent :: ClientSession -> RoomID -> EventType -> StateKey -> MatrixIO StateEvent +getRoomStateEvent session (RoomID rid) (EventType et) (StateKey key) = do + request <- mkRequest session True $ "/_matrix/client/v3/rooms/" <> rid <> "/state" <> et <> "/" <> key + doRequest session request + +data Dir + = -- | Forward + F + | -- | Backward + B + +renderDir :: Dir -> B.ByteString +renderDir F = "f" +renderDir B = "b" + +data PaginatedRoomMessages = PaginatedRoomMessages + { chunk :: [RoomEvent] + , end :: Maybe T.Text + -- ^ A token corresponding to the end of chunk. + , start :: T.Text + -- ^ A token corresponding to the start of chunk. + , state :: [StateEvent] + -- ^ A list of state events relevant to showing the chunk. + } + deriving (Show) + +instance FromJSON PaginatedRoomMessages where + parseJSON = withObject "PaginatedRoomMessages" $ \o -> do + chunk <- o .: "chunk" + end <- o .:? "end" + start <- o .: "start" + state <- fmap (fromMaybe []) $ o .:? "state" + pure $ PaginatedRoomMessages{..} + +getRoomMessages :: + ClientSession -> + -- | The room to get events from. + RoomID -> + -- | The direction to return events from. + Dir -> + -- | A 'RoomEventFilter' to filter returned events with. + Maybe RoomEventFilter -> + -- | The Since value to start returning events from. + T.Text -> + -- | The maximum number of events to return. Default: 10. + Maybe Int -> + -- | The token to stop returning events at. + Maybe Int -> + MatrixIO PaginatedRoomMessages +getRoomMessages session (RoomID rid) dir roomFilter fromToken limit toToken = do + request <- mkRequest session True $ "/_matrix/client/v3/rooms/" <> rid <> "/messages" + let dir' = "dir=" <> renderDir dir + filter' = BL.toStrict . mappend "filter=" . encode <$> roomFilter + from' = encodeUtf8 $ "from=" <> fromToken + limit' = BL.toStrict . mappend "limit=" . encode <$> limit + to' = BL.toStrict . mappend "from=" . encode <$> toToken + queryString = mappend "?" $ mconcat $ intersperse "&" $ [dir', from'] <> catMaybes [to', limit', filter'] + doRequest session $ request{HTTP.queryString = queryString} + +{- | Send arbitrary state events to a room. These events will be overwritten if +, and all match. +https://spec.matrix.org/v1.1/client-server-api/#put_matrixclientv3roomsroomidstateeventtypestatekey +-} +sendRoomStateEvent :: ClientSession -> RoomID -> EventType -> StateKey -> Value -> MatrixIO EventID +sendRoomStateEvent session (RoomID rid) (EventType et) (StateKey key) event = do + request <- mkRequest session True $ "/_matrix/client/v3/rooms/" <> escapeUriComponent rid <> "/state/" <> escapeUriComponent et <> "/" <> escapeUriComponent key + doRequest session $ + request + { HTTP.method = "PUT" + , HTTP.requestBody = HTTP.RequestBodyLBS $ encode event + } + +newtype TxnID = TxnID T.Text deriving (Show, Eq) + +{- | This endpoint is used to send a message event to a room. +https://spec.matrix.org/v1.1/client-server-api/#put_matrixclientv3roomsroomidsendeventtypetxnid +-} +sendMessage :: ClientSession -> RoomID -> Event -> TxnID -> MatrixIO EventID +sendMessage session (RoomID roomId) event (TxnID txnId) = do + request <- mkRequest session True path + doRequest + session + ( request + { HTTP.method = "PUT" + , HTTP.requestBody = HTTP.RequestBodyLBS $ encode event + } + ) + where + path = "/_matrix/client/r0/rooms/" <> roomId <> "/send/" <> eventId <> "/" <> txnId + eventId = eventType event + +redact :: ClientSession -> RoomID -> EventID -> TxnID -> T.Text -> MatrixIO EventID +redact session (RoomID rid) (EventID eid) (TxnID txnid) reason = do + request <- mkRequest session True $ "/_matrix/client/v3/rooms/" <> rid <> "/redact/" <> eid <> "/" <> txnid + let body = object ["reason" .= String reason] + doRequest session $ + request + { HTTP.method = "PUT" + , HTTP.requestBody = HTTP.RequestBodyLBS $ encode body + } + +------------------------------------------------------------------------------- +-- Room API Calls https://spec.matrix.org/v1.1/client-server-api/#rooms-1 + +{- | Create a new room with various configuration options. +https://spec.matrix.org/v1.1/client-server-api/#post_matrixclientv3createroom +-} +createRoom :: ClientSession -> RoomCreateRequest -> MatrixIO RoomID +createRoom session rcr = do + request <- mkRequest session True "/_matrix/client/v3/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 "UNKNOWN" "" Nothing + +newtype RoomAlias = RoomAlias T.Text deriving (Show, Eq, Ord, Hashable) + +data ResolvedRoomAlias = ResolvedRoomAlias + { roomAlias :: RoomAlias + , roomID :: RoomID + -- ^ The room ID for this room alias. + , servers :: [T.Text] + -- ^ A list of servers that are aware of this room alias. + } + deriving (Show) + +-- | Boilerplate data type for an aeson instance +data RoomAliasMetadata = RoomAliasMetadata + { ramRoomID :: RoomID + , ramServers :: [T.Text] + } + +instance FromJSON RoomAliasMetadata where + parseJSON = withObject "ResolvedRoomAlias" $ \o -> do + ramRoomID <- fmap RoomID $ o .: "room_id" + ramServers <- o .: "servers" + pure $ RoomAliasMetadata{..} + +{- | Requests that the server resolve a room alias to a room ID. +https://spec.matrix.org/v1.1/client-server-api/#get_matrixclientv3directoryroomroomalias +-} +resolveRoomAlias :: ClientSession -> RoomAlias -> MatrixIO ResolvedRoomAlias +resolveRoomAlias session r@(RoomAlias alias) = do + request <- mkRequest session True $ "/_matrix/client/v3/directory/room/" <> escapeUriComponent alias + resp <- doRequest session $ request{HTTP.method = "GET"} + case resp of + Left err -> pure $ Left err + Right RoomAliasMetadata{..} -> pure $ Right $ ResolvedRoomAlias r ramRoomID ramServers + +{- | Create a mapping of room alias to room ID. +https://spec.matrix.org/v1.1/client-server-api/#put_matrixclientv3directoryroomroomalias +-} +setRoomAlias :: ClientSession -> RoomAlias -> RoomID -> MatrixIO () +setRoomAlias session (RoomAlias alias) (RoomID roomId) = do + request <- mkRequest session True $ "/_matrix/client/v3/directory/room/" <> escapeUriComponent alias + doRequestExpectEmptyResponse session "set room alias" $ + request + { HTTP.method = "PUT" + , HTTP.requestBody = HTTP.RequestBodyLBS $ encode $ object ["room_id" .= roomId] + } + +{- | Delete a mapping of room alias to room ID. +https://spec.matrix.org/v1.1/client-server-api/#delete_matrixclientv3directoryroomroomalias +-} +deleteRoomAlias :: ClientSession -> RoomAlias -> MatrixIO () +deleteRoomAlias session (RoomAlias alias) = do + request <- mkRequest session True $ "/_matrix/client/v3/directory/room/" <> escapeUriComponent alias + doRequestExpectEmptyResponse session "delete room alias" $ request{HTTP.method = "DELETE"} + +newtype ResolvedAliases = ResolvedAliases [RoomAlias] + +instance FromJSON ResolvedAliases where + parseJSON = withObject "ResolvedAliases" $ \o -> do + aliases <- o .: "aliases" + pure $ ResolvedAliases (RoomAlias <$> aliases) + +{- | Get a list of aliases maintained by the local server for the given room. +https://spec.matrix.org/v1.1/client-server-api/#get_matrixclientv3roomsroomidaliases +-} +getRoomAliases :: ClientSession -> RoomID -> MatrixIO [RoomAlias] +getRoomAliases session (RoomID rid) = do + request <- mkRequest session True $ "/_matrix/client/v3/rooms/" <> rid <> "/aliases" + resp <- + doRequest + session + $ request{HTTP.method = "GET"} + case resp of + Left err -> pure $ Left err + Right (ResolvedAliases aliases) -> pure $ Right aliases + +{- | A newtype wrapper to decoded nested list + +>>> decode "{\"joined_rooms\": [\"!foo:example.com\"]}" :: Maybe JoinedRooms +Just (JoinedRooms {unRooms = [RoomID "!foo:example.com"]}) +-} +newtype JoinedRooms = JoinedRooms {unRooms :: [RoomID]} deriving (Show) + +instance FromJSON JoinedRooms where + parseJSON (Object v) = do + rooms <- v .: "joined_rooms" + pure . JoinedRooms $ RoomID <$> rooms + parseJSON _ = mzero + +{- | Returns a list of the user’s current rooms. +https://spec.matrix.org/v1.1/client-server-api/#get_matrixclientv3joined_rooms +-} +getJoinedRooms :: ClientSession -> MatrixIO [RoomID] +getJoinedRooms session = do + request <- mkRequest session True "/_matrix/client/r0/joined_rooms" + response <- doRequest session request + pure $ unRooms <$> response + +newtype RoomID = RoomID T.Text deriving (Show, Eq, Ord, Hashable) + +instance FromJSON RoomID where + parseJSON (Object v) = RoomID <$> v .: "room_id" + parseJSON _ = mzero + +{- | Invites a user to participate in a particular room. They do not +start participating in the room until they actually join the room. +https://spec.matrix.org/v1.1/client-server-api/#post_matrixclientv3roomsroomidinvite +-} +inviteToRoom :: ClientSession -> RoomID -> UserID -> Maybe T.Text -> MatrixIO () +inviteToRoom session (RoomID rid) (UserID uid) reason = do + request <- mkRequest session True $ "/_matrix/client/v3/rooms/" <> rid <> "/invite" + let body = object $ [("user_id", toJSON uid)] <> catMaybes [fmap (("reason",) . toJSON) reason] + doRequestExpectEmptyResponse session "invite" $ + request + { HTTP.method = "POST" + , HTTP.requestBody = HTTP.RequestBodyLBS $ encode body + } + +{- | Note that this API takes either a room ID or alias, unlike 'joinRoomById' +https://spec.matrix.org/v1.1/client-server-api/#post_matrixclientv3joinroomidoralias +-} +joinRoom :: ClientSession -> T.Text -> MatrixIO RoomID +joinRoom session roomName = do + request <- mkRequest session True $ "/_matrix/client/r0/join/" <> roomNameUrl + doRequest session (request{HTTP.method = "POST"}) + where + roomNameUrl = decodeUtf8 . urlEncode True . encodeUtf8 $ roomName + +{- | Starts a user participating in a particular room, if that user is +allowed to participate in that room. +https://spec.matrix.org/v1.1/client-server-api/#post_matrixclientv3roomsroomidjoin +-} +joinRoomById :: ClientSession -> RoomID -> MatrixIO RoomID +joinRoomById session (RoomID roomId) = do + request <- mkRequest session True $ "/_matrix/client/r0/rooms/" <> roomId <> "/join" + doRequest session (request{HTTP.method = "POST"}) + +{- | This API “knocks” on the room to ask for permission to join, if +the user is allowed to knock on the room. +https://spec.matrix.org/v1.1/client-server-api/#post_matrixclientv3knockroomidoralias +-} +knockOnRoom :: ClientSession -> Either RoomID RoomAlias -> [T.Text] -> Maybe T.Text -> MatrixIO RoomID +knockOnRoom session room servers reason = do + request <- mkRequest session True $ " /_matrix/client/v3/knock/" <> indistinct (bimap coerce coerce room) + let body = object $ catMaybes [fmap (("reason",) . toJSON) reason] + doRequest session $ + request + { HTTP.method = "POST" + , HTTP.requestBody = HTTP.RequestBodyLBS $ encode body + , HTTP.queryString = encodeUtf8 $ "?server_name=" <> mconcat (intersperse "," servers) + } + +{- | Stops remembering a particular room. +https://spec.matrix.org/v1.1/client-server-api/#post_matrixclientv3roomsroomidforget +-} +forgetRoom :: ClientSession -> RoomID -> MatrixIO () +forgetRoom session (RoomID roomId) = do + request <- mkRequest session True $ "/_matrix/client/v3/rooms/" <> roomId <> "/forget" + doRequestExpectEmptyResponse session "forget" (request{HTTP.method = "POST"}) + +{- | Stop participating in a particular room. +https://spec.matrix.org/v1.1/client-server-api/#post_matrixclientv3roomsroomidleave +-} +leaveRoomById :: ClientSession -> RoomID -> MatrixIO () +leaveRoomById session (RoomID roomId) = do + request <- mkRequest session True $ "/_matrix/client/r0/rooms/" <> roomId <> "/leave" + doRequestExpectEmptyResponse session "leave" (request{HTTP.method = "POST"}) + +{- | Kick a user from the room. +https://spec.matrix.org/v1.1/client-server-api/#post_matrixclientv3roomsroomidkick +-} +kickUser :: ClientSession -> RoomID -> UserID -> Maybe T.Text -> MatrixIO () +kickUser session (RoomID roomId) (UserID uid) reason = do + request <- mkRequest session True $ "/_matrix/client/v3/rooms/" <> roomId <> "/kick" + let body = object $ [("user_id", toJSON uid)] <> catMaybes [fmap (("reason",) . toJSON) reason] + doRequestExpectEmptyResponse session "kick" $ + request + { HTTP.method = "POST" + , HTTP.requestBody = HTTP.RequestBodyLBS $ encode body + } + +{- | Ban a user in the room. If the user is currently in the room, also kick them. +https://spec.matrix.org/v1.1/client-server-api/#post_matrixclientv3roomsroomidban +-} +banUser :: ClientSession -> RoomID -> UserID -> Maybe T.Text -> MatrixIO () +banUser session (RoomID roomId) (UserID uid) reason = do + request <- mkRequest session True $ "/_matrix/client/v3/rooms/" <> roomId <> "/ban" + let body = object $ [("user_id", toJSON uid)] <> catMaybes [fmap (("reason",) . toJSON) reason] + doRequestExpectEmptyResponse session "ban" $ + request + { HTTP.method = "POST" + , HTTP.requestBody = HTTP.RequestBodyLBS $ encode body + } + +{- | Unban a user from the room. This allows them to be invited to the +room, and join if they would otherwise be allowed to join according +to its join rules. +https://spec.matrix.org/v1.1/client-server-api/#post_matrixclientv3roomsroomidunban +-} +unbanUser :: ClientSession -> RoomID -> UserID -> Maybe T.Text -> MatrixIO () +unbanUser session (RoomID roomId) (UserID uid) reason = do + request <- mkRequest session True $ "/_matrix/client/v3/rooms/" <> roomId <> "/unban" + let body = object $ [("user_id", toJSON uid)] <> catMaybes [fmap (("reason",) . toJSON) reason] + doRequestExpectEmptyResponse session "unban" $ + request + { HTTP.method = "POST" + , HTTP.requestBody = HTTP.RequestBodyLBS $ encode body + } + +data Visibility = Public | Private + deriving (Show) + +instance ToJSON Visibility where + toJSON = \case + Public -> String "public" + Private -> String "private" + +instance FromJSON Visibility where + parseJSON = withText "Visibility" $ \case + "public" -> pure Public + "private" -> pure Private + _ -> mzero + +newtype GetVisibility = GetVisibility {getVisibility :: Visibility} + +instance FromJSON GetVisibility where + parseJSON = withObject "GetVisibility" $ \o -> do + getVisibility <- o .: "visibility" + pure $ GetVisibility{..} + +{- | Gets the visibility of a given room on the server’s public room directory. +https://spec.matrix.org/v1.1/client-server-api/#get_matrixclientv3directorylistroomroomid +-} +checkRoomVisibility :: ClientSession -> RoomID -> MatrixIO Visibility +checkRoomVisibility session (RoomID rid) = do + request <- mkRequest session True $ "/_matrix/client/v3/directory/list/room/" <> rid + fmap getVisibility <$> doRequest session request + +{- | Sets the visibility of a given room in the server’s public room directory. +https://spec.matrix.org/v1.1/client-server-api/#put_matrixclientv3directorylistroomroomid +-} +setRoomVisibility :: ClientSession -> RoomID -> Visibility -> MatrixIO () +setRoomVisibility session (RoomID rid) visibility = do + request <- mkRequest session True $ "/_matrix/client/v3/directory/list/room/" <> rid + let body = object [("visibility", toJSON visibility)] + doRequestExpectEmptyResponse session "set room visibility" $ + request + { HTTP.method = "PUT" + , HTTP.requestBody = HTTP.RequestBodyLBS $ encode body + } + +{- | A pagination token from a previous request, allowing clients to +get the next (or previous) batch of rooms. The direction of +pagination is specified solely by which token is supplied, rather +than via an explicit flag. +-} +newtype PaginationChunk = PaginationChunk {getChunk :: T.Text} + deriving stock (Show) + deriving newtype (ToJSON, FromJSON) + +data Room = Room + { aliases :: Maybe [T.Text] + , avatarUrl :: Maybe T.Text + , canonicalAlias :: Maybe T.Text + , guestCanJoin :: Bool + , joinRule :: Maybe T.Text + , name :: Maybe T.Text + , numJoinedMembers :: Int + , roomId :: RoomID + , topic :: Maybe T.Text + , worldReadable :: Bool + } + deriving (Show) + +instance FromJSON Room where + parseJSON = withObject "Room" $ \o -> do + aliases <- o .:? "aliases" + avatarUrl <- o .:? "avatar_url" + canonicalAlias <- o .:? "canonical_alias" + guestCanJoin <- o .: "guest_can_join" + joinRule <- o .:? "join_rule" + name <- o .:? "name" + numJoinedMembers <- o .: "num_joined_members" + roomId <- fmap RoomID $ o .: "room_id" + topic <- o .:? "topic" + worldReadable <- o .: "world_readable" + pure $ Room{..} + +data PublicRooms = PublicRooms + { prChunk :: [Room] + , prNextBatch :: Maybe PaginationChunk + , prPrevBatch :: Maybe PaginationChunk + , prTotalRoomCountEstimate :: Maybe Int + } + deriving (Show) + +instance FromJSON PublicRooms where + parseJSON = withObject "PublicRooms" $ \o -> do + prChunk <- o .: "chunk" + prNextBatch <- o .:? "next_batch" + prPrevBatch <- o .:? "prev_batch" + prTotalRoomCountEstimate <- o .:? "total_room_count_estimate" + pure $ PublicRooms{..} + +{- | Lists the public rooms on the server. +https://spec.matrix.org/v1.1/client-server-api/#get_matrixclientv3publicrooms +-} +getPublicRooms :: ClientSession -> Maybe Int -> Maybe PaginationChunk -> MatrixIO PublicRooms +getPublicRooms session limit chunk = do + request <- mkRequest session True "/_matrix/client/v3/publicRooms" + let since = fmap (mappend "since=" . getChunk) chunk + limit' = fmap (mappend "limit=" . tshow) limit + queryString = encodeUtf8 $ mconcat $ intersperse "&" $ catMaybes [since, limit'] + doRequest session $ + request{HTTP.queryString = queryString} + +newtype ThirdPartyInstanceId = ThirdPartyInstanceId T.Text + deriving (FromJSON, ToJSON) + +{- | Lists the public rooms on the server, with optional filter. +https://spec.matrix.org/v1.1/client-server-api/#post_matrixclientv3publicrooms +-} +getPublicRooms' :: ClientSession -> Maybe Int -> Maybe PaginationChunk -> Maybe T.Text -> Maybe Bool -> Maybe ThirdPartyInstanceId -> MatrixIO PublicRooms +getPublicRooms' session limit chunk searchTerm includeAllNetworks thirdPartyId = do + request <- mkRequest session True "/_matrix/client/v3/publicRooms" + let filter' = object $ catMaybes [fmap (("generic_search_term",) . toJSON) searchTerm] + since = fmap (("since",) . toJSON) chunk + limit' = fmap (("limit",) . toJSON) limit + includeAllNetworks' = fmap (("include_all_networks",) . toJSON) includeAllNetworks + thirdPartyId' = fmap (("third_party_instance_id",) . toJSON) thirdPartyId + body = object $ [("filter", filter')] <> catMaybes [since, limit', includeAllNetworks', thirdPartyId'] + doRequest session $ + request + { HTTP.method = "POST" + , HTTP.requestBody = HTTP.RequestBodyLBS $ encode body + } + +------------------------------------------------------------------------------- +-- https://matrix.org/docs/spec/client_server/latest#post-matrix-client-r0-user-userid-filter +newtype FilterID = FilterID T.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 [T.Text] + , efNotTypes :: Maybe [T.Text] + , efSenders :: Maybe [T.Text] + , efTypes :: Maybe [T.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 [T.Text] + , refNotTypes :: Maybe [T.Text] + , refSenders :: Maybe [T.Text] + , refTypes :: Maybe [T.Text] + , refLazyLoadMembers :: Maybe Bool + , refIncludeRedundantMembers :: Maybe Bool + , refNotRooms :: Maybe [T.Text] + , refRooms :: Maybe [T.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 [T.Text] + , sfNotTypes :: Maybe [T.Text] + , sfSenders :: Maybe [T.Text] + , sfTypes :: Maybe [T.Text] + , sfLazyLoadMembers :: Maybe Bool + , sfIncludeRedundantMembers :: Maybe Bool + , sfNotRooms :: Maybe [T.Text] + , sfRooms :: Maybe [T.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 [T.Text] + , rfRooms :: Maybe [T.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 [T.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 :: T.Text} + deriving (Show, Eq) + deriving newtype (FromJSON, ToJSON) + +data RoomEvent = RoomEvent + { reContent :: Event + , reType :: T.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 T.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 = String . tshow + +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 :: T.Text + , srRooms :: Maybe SyncResultRoom + } + deriving (Show, Eq, Generic) + +data SyncResultRoom = SyncResultRoom + { srrJoin :: Maybe (Map T.Text JoinedRoomSync) + , srrInvite :: Maybe (Map T.Text InvitedRoomSync) + } + deriving (Show, Eq, Generic) + +data InvitedRoomSync = InvitedRoomSync + deriving (Show, Eq, Generic) + +unFilterID :: FilterID -> T.Text +unFilterID (FilterID x) = x + +------------------------------------------------------------------------------- +-- https://matrix.org/docs/spec/client_server/latest#forming-relationships-between-events + +{- | 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 -> T.Text -> T.Text -> T.Text +addReplyBody (Author author) old reply = + let oldLines = T.lines old + headLine = "> <" <> author <> ">" <> maybe "" (mappend " ") (headMaybe oldLines) + newBody = [headLine] <> map (mappend "> ") (tail' oldLines) <> [""] <> [reply] + in T.dropEnd 1 $ T.unlines newBody + +addReplyFormattedBody :: RoomID -> EventID -> Author -> T.Text -> T.Text -> T.Text +addReplyFormattedBody (RoomID roomID) (EventID eventID) (Author author) old reply = + T.unlines + [ "" + , "
" + , " roomID <> "/" <> eventID <> "\">In reply to" + , " author <> "\">" <> author <> "" + , "
" + , " " <> old + , "
" + , "" + , reply + ] + +{- | Convert body by encoding HTML special char + +>>> toFormattedBody "& " +"& <test>" +-} +toFormattedBody :: T.Text -> T.Text +toFormattedBody = T.concatMap char + where + char x = case x of + '<' -> "<" + '>' -> ">" + '&' -> "&" + _ -> T.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 T.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" (tshow <$> presenceM) + <> toQs "timeout" (tshow <$> 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 T.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 :: T.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 + +getAccountData' :: (FromJSON a) => ClientSession -> UserID -> T.Text -> MatrixIO a +getAccountData' session userID t = + mkRequest session True (accountDataPath userID t) >>= doRequest session + +setAccountData' :: (ToJSON a) => ClientSession -> UserID -> T.Text -> a -> MatrixIO () +setAccountData' session userID t value = do + request <- mkRequest session True $ accountDataPath userID t + doRequestExpectEmptyResponse session "set account data" $ + request + { HTTP.method = "PUT" + , HTTP.requestBody = HTTP.RequestBodyLBS $ encode value + } + +accountDataPath :: UserID -> T.Text -> T.Text +accountDataPath (UserID userID) t = + "/_matrix/client/r0/user/" <> userID <> "/account_data/" <> t + +class (FromJSON a, ToJSON a) => AccountData a where + accountDataType :: proxy a -> T.Text + +getAccountData :: forall a. (AccountData a) => ClientSession -> UserID -> MatrixIO a +getAccountData session userID = + getAccountData' session userID $ + accountDataType (Proxy :: Proxy a) + +setAccountData :: forall a. (AccountData a) => ClientSession -> UserID -> a -> MatrixIO () +setAccountData session userID = + setAccountData' session userID $ + accountDataType (Proxy :: Proxy a) + +------------------------------------------------------------------------------- +-- Utils + +headMaybe :: [a] -> Maybe a +headMaybe xs = case xs of + [] -> Nothing + (x : _) -> Just x + +tail' :: [a] -> [a] +tail' xs = case xs of + [] -> [] + (_ : rest) -> rest + +indistinct :: Either x x -> x +indistinct = id `either` id + +tshow :: (Show a) => a -> T.Text tshow = T.pack . show escapeUriComponent :: T.Text -> T.Text diff --git a/src/Network/Matrix/Client/Lens.hs b/src/Network/Matrix/Client/Lens.hs --- a/src/Network/Matrix/Client/Lens.hs +++ b/src/Network/Matrix/Client/Lens.hs @@ -1,117 +1,118 @@ {-# LANGUAGE RankNTypes #-} -module Network.Matrix.Client.Lens - ( -- MessageText - _mtBody - , _mtType - , _mtFormat - , _mtFormattedBody + +module Network.Matrix.Client.Lens ( + -- MessageText + _mtBody, + _mtType, + _mtFormat, + _mtFormattedBody, -- RoomMessage - , _RoomMessageText + _RoomMessageText, -- Event - , _EventRoomMessage - , _EventRoomReply - , _EventRoomEdit - , _EventUnknown + _EventRoomMessage, + _EventRoomReply, + _EventRoomEdit, + _EventUnknown, -- EventFilter - , efLimit - , _efNotSenders - , _efNotTypes - , _efSenders - , _efTypes + efLimit, + _efNotSenders, + _efNotTypes, + _efSenders, + _efTypes, -- PaginatedRoomMessages - , _chunk - , _end - , _start - , _state + _chunk, + _end, + _start, + _state, -- ResolvedRoomAlias - , _roomAlias - , _roomID - , _servers + _roomAlias, + _roomID, + _servers, -- RoomEventFilter - , _refLimit - , _refNotSenders - , _refNotTypes - , _refSenders - , _refTypes - , _refLazyLoadMembers - , _refIncludeRedundantMembers - , _refNotRooms - , _refRooms - , _refContainsUrl + _refLimit, + _refNotSenders, + _refNotTypes, + _refSenders, + _refTypes, + _refLazyLoadMembers, + _refIncludeRedundantMembers, + _refNotRooms, + _refRooms, + _refContainsUrl, -- StateContent - , _StateContentMRCreate - , _StateContentMRCanonicalAlias - , _StateContentMRGuestAccess - , _StateContentMRHistoryVisibility - , _StateContentMRName - , _StateContentMRTopic - , _StateContentMROther + _StateContentMRCreate, + _StateContentMRCanonicalAlias, + _StateContentMRGuestAccess, + _StateContentMRHistoryVisibility, + _StateContentMRName, + _StateContentMRTopic, + _StateContentMROther, -- StateEvent - , _seContent - , _seEventId - , _seOriginServerTimestamp - , _sePreviousContent - , _seRoomId - , _seSender - , _seStateKey - , _seEventType - , _seUnsigned + _seContent, + _seEventId, + _seOriginServerTimestamp, + _sePreviousContent, + _seRoomId, + _seSender, + _seStateKey, + _seEventType, + _seUnsigned, -- StateFilter - , _sfLimit - , _sfNotSenders - , _sfTypes - , _sfLazyLoadMembers - , _sfIncludeRedundantMembers - , _sfNotRooms - , _sfRooms - , _sfContainsUrl + _sfLimit, + _sfNotSenders, + _sfTypes, + _sfLazyLoadMembers, + _sfIncludeRedundantMembers, + _sfNotRooms, + _sfRooms, + _sfContainsUrl, -- RoomFilter - , _rfNotRooms - , _rfRooms - , _rfEphemeral - , _rfIncludeLeave - , _rfState - , _rfTimeline - , _rfAccountData + _rfNotRooms, + _rfRooms, + _rfEphemeral, + _rfIncludeLeave, + _rfState, + _rfTimeline, + _rfAccountData, -- Filter - , _filterEventFields - , _filterEventFormat - , _filterPresence - , _filterAccountData - , _filterRoom + _filterEventFields, + _filterEventFormat, + _filterPresence, + _filterAccountData, + _filterRoom, -- RoomEvent - , _reContent - , _reType - , _reEventId - , _reSender + _reContent, + _reType, + _reEventId, + _reSender, -- RoomSummary - , _rsJoinedMemberCount - , _rsInvitedMemberCount + _rsJoinedMemberCount, + _rsInvitedMemberCount, -- TimelineSync - , _tsEvents - , _tsLimited - , _tsPrevBatch + _tsEvents, + _tsLimited, + _tsPrevBatch, -- JoinedRoomSync - , _jrsSummary - , _jrsTimeline + _jrsSummary, + _jrsTimeline, -- SyncResult - , _srNextBatch - , _srRooms + _srNextBatch, + _srRooms, -- SyncResultRoom - , _srrJoin - , _srrInvite - ) where + _srrJoin, + _srrInvite, +) where import Network.Matrix.Client import qualified Data.Aeson as J import Data.Coerce -import qualified Data.Text as T import qualified Data.Map.Strict as M import Data.Profunctor (Choice, dimap, right') +import qualified Data.Text as T -type Lens' s a = forall f. Functor f => (a -> f a) -> s -> f s -type Prism' s a = forall p f. (Choice p, Applicative f) => p a (f a) -> p s (f s) +type Lens' s a = forall f. (Functor f) => (a -> f a) -> s -> f s +type Prism' s a = forall p f. (Choice p, Applicative f) => p a (f a) -> p s (f s) lens :: (s -> a) -> (s -> a -> s) -> Lens' s a lens sa sbt afb s = sbt s <$> afb (sa s) @@ -128,31 +129,31 @@ _mtBody = lens getter setter where getter = mtBody - setter mt t = mt { mtBody = t } + setter mt t = mt{mtBody = t} _mtType :: Lens' MessageText MessageTextType _mtType = lens getter setter where getter = mtType - setter mt t = mt { mtType = t } + setter mt t = mt{mtType = t} _mtFormat :: Lens' MessageText (Maybe T.Text) _mtFormat = lens getter setter where getter = mtFormat - setter mt t = mt { mtFormat = t } + setter mt t = mt{mtFormat = t} _mtFormattedBody :: Lens' MessageText (Maybe T.Text) _mtFormattedBody = lens getter setter where getter = mtFormattedBody - setter mt t = mt { mtFormattedBody = t} + setter mt t = mt{mtFormattedBody = t} _RoomMessageText :: Lens' RoomMessage MessageText _RoomMessageText = lens getter setter where getter = coerce - setter _ t = RoomMessageText t + setter _ = RoomMessageText _EventRoomMessage :: Prism' Event RoomMessage _EventRoomMessage = prism' to from @@ -186,133 +187,133 @@ _efLimit = lens getter setter where getter = efLimit - setter ef lim = ef { efLimit = lim } + setter ef lim = ef{efLimit = lim} _efNotSenders :: Lens' EventFilter (Maybe [T.Text]) _efNotSenders = lens getter setter where getter = efNotSenders - setter ef ns = ef { efNotSenders = ns } + setter ef ns = ef{efNotSenders = ns} _efNotTypes :: Lens' EventFilter (Maybe [T.Text]) _efNotTypes = lens getter setter where getter = efNotTypes - setter ef nt = ef { efNotTypes = nt } + setter ef nt = ef{efNotTypes = nt} _efSenders :: Lens' EventFilter (Maybe [T.Text]) _efSenders = lens getter setter where getter = efSenders - setter ef s = ef { efSenders = s } + setter ef s = ef{efSenders = s} _efTypes :: Lens' EventFilter (Maybe [T.Text]) _efTypes = lens getter setter where getter = efTypes - setter ef t = ef { efTypes = t } + setter ef t = ef{efTypes = t} _chunk :: Lens' PaginatedRoomMessages [RoomEvent] _chunk = lens getter setter where getter = chunk - setter prm c = prm { chunk = c } + setter prm c = prm{chunk = c} _end :: Lens' PaginatedRoomMessages (Maybe T.Text) _end = lens getter setter where getter = end - setter prm e = prm { end = e } + setter prm e = prm{end = e} _start :: Lens' PaginatedRoomMessages T.Text _start = lens getter setter where getter = start - setter prm s = prm { start = s } + setter prm s = prm{start = s} _state :: Lens' PaginatedRoomMessages [StateEvent] _state = lens getter setter where getter = state - setter prm s = prm { state = s } + setter prm s = prm{state = s} _roomAlias :: Lens' ResolvedRoomAlias RoomAlias _roomAlias = lens getter setter where getter = roomAlias - setter rra ra = rra { roomAlias = ra } + setter rra ra = rra{roomAlias = ra} _roomID :: Lens' ResolvedRoomAlias RoomID _roomID = lens getter setter where getter = roomID - setter rra rid = rra { roomID = rid } + setter rra rid = rra{roomID = rid} _servers :: Lens' ResolvedRoomAlias [T.Text] _servers = lens getter setter where getter = servers - setter rra s = rra { servers = s } + setter rra s = rra{servers = s} _refLimit :: Lens' RoomEventFilter (Maybe Int) _refLimit = lens getter setter where getter = refLimit - setter ref rl = ref { refLimit = rl } + setter ref rl = ref{refLimit = rl} _refNotSenders :: Lens' RoomEventFilter (Maybe [T.Text]) _refNotSenders = lens getter setter where getter = refNotSenders - setter ref ns = ref { refNotSenders = ns } + setter ref ns = ref{refNotSenders = ns} _refNotTypes :: Lens' RoomEventFilter (Maybe [T.Text]) _refNotTypes = lens getter setter where getter = refNotTypes - setter ref rnt = ref { refNotTypes = rnt } + setter ref rnt = ref{refNotTypes = rnt} _refSenders :: Lens' RoomEventFilter (Maybe [T.Text]) _refSenders = lens getter setter - where - getter = refSenders - setter ref rs = ref { refSenders = rs } + where + getter = refSenders + setter ref rs = ref{refSenders = rs} _refTypes :: Lens' RoomEventFilter (Maybe [T.Text]) _refTypes = lens getter setter where getter = refTypes - setter ref rt = ref { refTypes = rt } + setter ref rt = ref{refTypes = rt} _refLazyLoadMembers :: Lens' RoomEventFilter (Maybe Bool) _refLazyLoadMembers = lens getter setter where getter = refLazyLoadMembers - setter ref rldm = ref { refLazyLoadMembers = rldm } + setter ref rldm = ref{refLazyLoadMembers = rldm} _refIncludeRedundantMembers :: Lens' RoomEventFilter (Maybe Bool) _refIncludeRedundantMembers = lens getter setter where getter = refIncludeRedundantMembers - setter ref rirm = ref { refIncludeRedundantMembers = rirm } + setter ref rirm = ref{refIncludeRedundantMembers = rirm} _refNotRooms :: Lens' RoomEventFilter (Maybe [T.Text]) _refNotRooms = lens getter setter where getter = refNotRooms - setter ref rnr = ref { refNotRooms = rnr } + setter ref rnr = ref{refNotRooms = rnr} _refRooms :: Lens' RoomEventFilter (Maybe [T.Text]) _refRooms = lens getter setter where getter = refRooms - setter ref rr = ref { refRooms = rr } + setter ref rr = ref{refRooms = rr} _refContainsUrl :: Lens' RoomEventFilter (Maybe Bool) _refContainsUrl = lens getter setter where getter = refContainsUrl - setter ref rcu = ref { refContainsUrl = rcu } + setter ref rcu = ref{refContainsUrl = rcu} _StateContentMRCreate :: Prism' StateContent MRCreate _StateContentMRCreate = prism' to from @@ -367,262 +368,262 @@ _seContent = lens getter setter where getter = seContent - setter sec c = sec { seContent = c } + setter sec c = sec{seContent = c} _seEventId :: Lens' StateEvent EventID _seEventId = lens getter setter where getter = seEventId - setter sec eid = sec { seEventId = eid } + setter sec eid = sec{seEventId = eid} _seOriginServerTimestamp :: Lens' StateEvent Integer _seOriginServerTimestamp = lens getter setter where getter = seOriginServerTimestamp - setter sec ts = sec { seOriginServerTimestamp = ts } + setter sec ts = sec{seOriginServerTimestamp = ts} _sePreviousContent :: Lens' StateEvent (Maybe J.Value) _sePreviousContent = lens getter setter where getter = sePreviousContent - setter sec c = sec { sePreviousContent = c } + setter sec c = sec{sePreviousContent = c} _seRoomId :: Lens' StateEvent RoomID _seRoomId = lens getter setter where getter = seRoomId - setter sec rid = sec { seRoomId = rid } + setter sec rid = sec{seRoomId = rid} _seSender :: Lens' StateEvent UserID _seSender = lens getter setter where getter = seSender - setter sec uid = sec { seSender = uid } + setter sec uid = sec{seSender = uid} _seStateKey :: Lens' StateEvent StateKey _seStateKey = lens getter setter where getter = seStateKey - setter sec key = sec { seStateKey = key } + setter sec key = sec{seStateKey = key} _seEventType :: Lens' StateEvent EventType _seEventType = lens getter setter where getter = seEventType - setter sec et = sec { seEventType = et } + setter sec et = sec{seEventType = et} _seUnsigned :: Lens' StateEvent (Maybe J.Value) _seUnsigned = lens getter setter where getter = seUnsigned - setter sec val = sec { seUnsigned = val } + setter sec val = sec{seUnsigned = val} _sfLimit :: Lens' StateFilter (Maybe Int) _sfLimit = lens getter setter where getter = sfLimit - setter sf sfl = sf { sfLimit = sfl } + setter sf sfl = sf{sfLimit = sfl} _sfNotSenders :: Lens' StateFilter (Maybe [T.Text]) _sfNotSenders = lens getter setter where getter = sfNotSenders - setter sf sfns = sf { sfNotSenders = sfns} + setter sf sfns = sf{sfNotSenders = sfns} _sfTypes :: Lens' StateFilter (Maybe [T.Text]) _sfTypes = lens getter setter where getter = sfTypes - setter sf sft = sf { sfTypes = sft } + setter sf sft = sf{sfTypes = sft} _sfLazyLoadMembers :: Lens' StateFilter (Maybe Bool) _sfLazyLoadMembers = lens getter setter where getter = sfLazyLoadMembers - setter sf sflm = sf { sfLazyLoadMembers = sflm } + setter sf sflm = sf{sfLazyLoadMembers = sflm} _sfIncludeRedundantMembers :: Lens' StateFilter (Maybe Bool) _sfIncludeRedundantMembers = lens getter setter where getter = sfIncludeRedundantMembers - setter sf sfirm = sf { sfIncludeRedundantMembers = sfirm } + setter sf sfirm = sf{sfIncludeRedundantMembers = sfirm} _sfNotRooms :: Lens' StateFilter (Maybe [T.Text]) _sfNotRooms = lens getter setter where getter = sfNotRooms - setter sf sfnr = sf { sfNotRooms = sfnr } + setter sf sfnr = sf{sfNotRooms = sfnr} _sfRooms :: Lens' StateFilter (Maybe [T.Text]) _sfRooms = lens getter setter where getter = sfRooms - setter sf sfr = sf { sfRooms = sfr } + setter sf sfr = sf{sfRooms = sfr} _sfContainsUrl :: Lens' StateFilter (Maybe Bool) _sfContainsUrl = lens getter setter where getter = sfContains_url - setter sf cu = sf { sfContains_url = cu } + setter sf cu = sf{sfContains_url = cu} _rfNotRooms :: Lens' RoomFilter (Maybe [T.Text]) _rfNotRooms = lens getter setter where getter = rfNotRooms - setter rm rfnr = rm { rfNotRooms = rfnr } + setter rm rfnr = rm{rfNotRooms = rfnr} _rfRooms :: Lens' RoomFilter (Maybe [T.Text]) _rfRooms = lens getter setter where getter = rfRooms - setter rm rfr = rm { rfRooms = rfr } + setter rm rfr = rm{rfRooms = rfr} _rfEphemeral :: Lens' RoomFilter (Maybe RoomEventFilter) _rfEphemeral = lens getter setter where getter = rfEphemeral - setter rm rfe = rm { rfEphemeral = rfe } + setter rm rfe = rm{rfEphemeral = rfe} _rfIncludeLeave :: Lens' RoomFilter (Maybe Bool) _rfIncludeLeave = lens getter setter where getter = rfIncludeLeave - setter rm rfil = rm { rfIncludeLeave = rfil } + setter rm rfil = rm{rfIncludeLeave = rfil} _rfState :: Lens' RoomFilter (Maybe StateFilter) _rfState = lens getter setter where getter = rfState - setter rm rfs = rm { rfState = rfs } + setter rm rfs = rm{rfState = rfs} _rfTimeline :: Lens' RoomFilter (Maybe RoomEventFilter) _rfTimeline = lens getter setter where getter = rfTimeline - setter rm rft = rm { rfTimeline = rft } + setter rm rft = rm{rfTimeline = rft} _rfAccountData :: Lens' RoomFilter (Maybe RoomEventFilter) _rfAccountData = lens getter setter where getter = rfAccountData - setter rm rfad = rm { rfAccountData = rfad } + setter rm rfad = rm{rfAccountData = rfad} _filterEventFields :: Lens' Filter (Maybe [T.Text]) _filterEventFields = lens getter setter where getter = filterEventFields - setter fltr fef = fltr { filterEventFields = fef } + setter fltr fef = fltr{filterEventFields = fef} _filterEventFormat :: Lens' Filter (Maybe EventFormat) _filterEventFormat = lens getter setter where getter = filterEventFormat - setter fltr fef = fltr { filterEventFormat = fef } + setter fltr fef = fltr{filterEventFormat = fef} _filterPresence :: Lens' Filter (Maybe EventFilter) _filterPresence = lens getter setter where getter = filterPresence - setter fltr fp = fltr { filterPresence = fp } + setter fltr fp = fltr{filterPresence = fp} _filterAccountData :: Lens' Filter (Maybe EventFilter) _filterAccountData = lens getter setter where getter = filterAccountData - setter fltr fac = fltr { filterAccountData = fac } + setter fltr fac = fltr{filterAccountData = fac} _filterRoom :: Lens' Filter (Maybe RoomFilter) _filterRoom = lens getter setter where getter = filterRoom - setter fltr fr = fltr { filterRoom = fr } + setter fltr fr = fltr{filterRoom = fr} _reContent :: Lens' RoomEvent Event _reContent = lens getter setter where getter = reContent - setter rEvent rc = rEvent { reContent = rc } + setter rEvent rc = rEvent{reContent = rc} _reType :: Lens' RoomEvent T.Text _reType = lens getter setter where getter = reType - setter rEvent rt = rEvent { reType = rt } + setter rEvent rt = rEvent{reType = rt} _reEventId :: Lens' RoomEvent EventID _reEventId = lens getter setter where getter = reEventId - setter rEvent reid = rEvent { reEventId = reid } + setter rEvent reid = rEvent{reEventId = reid} _reSender :: Lens' RoomEvent Author _reSender = lens getter setter where getter = reSender - setter rEvent res = rEvent { reSender = res } + setter rEvent res = rEvent{reSender = res} _rsJoinedMemberCount :: Lens' RoomSummary (Maybe Int) _rsJoinedMemberCount = lens getter setter where getter = rsJoinedMemberCount - setter rs rsjmc = rs { rsJoinedMemberCount = rsjmc } + setter rs rsjmc = rs{rsJoinedMemberCount = rsjmc} _rsInvitedMemberCount :: Lens' RoomSummary (Maybe Int) _rsInvitedMemberCount = lens getter setter where getter = rsInvitedMemberCount - setter rs rsimc = rs { rsInvitedMemberCount = rsimc } + setter rs rsimc = rs{rsInvitedMemberCount = rsimc} _tsEvents :: Lens' TimelineSync (Maybe [RoomEvent]) _tsEvents = lens getter setter where getter = tsEvents - setter ts tse = ts { tsEvents = tse } + setter ts tse = ts{tsEvents = tse} _tsLimited :: Lens' TimelineSync (Maybe Bool) _tsLimited = lens getter setter where getter = tsLimited - setter ts tsl = ts { tsLimited = tsl } + setter ts tsl = ts{tsLimited = tsl} _tsPrevBatch :: Lens' TimelineSync (Maybe T.Text) _tsPrevBatch = lens getter setter where getter = tsPrevBatch - setter ts tspb = ts { tsPrevBatch = tspb } + setter ts tspb = ts{tsPrevBatch = tspb} _jrsSummary :: Lens' JoinedRoomSync (Maybe RoomSummary) _jrsSummary = lens getter setter where getter = jrsSummary - setter jrs jrss = jrs { jrsSummary = jrss } + setter jrs jrss = jrs{jrsSummary = jrss} _jrsTimeline :: Lens' JoinedRoomSync TimelineSync _jrsTimeline = lens getter setter where getter = jrsTimeline - setter jrs jrst = jrs { jrsTimeline = jrst } + setter jrs jrst = jrs{jrsTimeline = jrst} _srNextBatch :: Lens' SyncResult T.Text _srNextBatch = lens getter setter where getter = srNextBatch - setter sr srnb = sr { srNextBatch = srnb } + setter sr srnb = sr{srNextBatch = srnb} _srRooms :: Lens' SyncResult (Maybe SyncResultRoom) _srRooms = lens getter setter where getter = srRooms - setter sr srr = sr { srRooms = srr } + setter sr srr = sr{srRooms = srr} _srrJoin :: Lens' SyncResultRoom (Maybe (M.Map T.Text JoinedRoomSync)) _srrJoin = lens getter setter where getter = srrJoin - setter srr srrj = srr { srrJoin = srrj } + setter srr srrj = srr{srrJoin = srrj} _srrInvite :: Lens' SyncResultRoom (Maybe (M.Map T.Text InvitedRoomSync)) _srrInvite = lens getter setter where getter = srrInvite - setter srr srri = srr { srrInvite = srri } + setter srr srri = srr{srrInvite = srri} 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 @@ -1,14 +1,14 @@ {-# LANGUAGE OverloadedStrings #-} -- | Matrix event data type -module Network.Matrix.Events - ( MessageTextType (..), +module Network.Matrix.Events ( + MessageTextType (..), MessageText (..), RoomMessage (..), Event (..), EventID (..), eventType, - ) +) where import Control.Applicative ((<|>)) @@ -18,140 +18,140 @@ import Data.Text (Text) data MessageTextType - = TextType - | EmoteType - | NoticeType - deriving (Eq, Show) + = 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 + 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" + 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) + { 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 + parseJSON (Object v) = + MessageText + <$> v .: "body" + <*> v .: "msgtype" + <*> v .:? "format" + <*> v .:? "formatted_body" + parseJSON _ = mzero messageTextAttr :: MessageText -> [Pair] messageTextAttr msg = - ["body" .= mtBody msg, "msgtype" .= mtType msg] <> format <> formattedBody + ["body" .= mtBody msg, "msgtype" .= mtType msg] <> format <> formattedBody where - omitNull k vM = maybe [] (\v -> [k .= v]) vM + omitNull k = maybe [] (\v -> [k .= v]) format = omitNull "format" $ mtFormat msg formattedBody = omitNull "formatted_body" $ mtFormattedBody msg instance ToJSON MessageText where - toJSON = object . messageTextAttr + toJSON = object . messageTextAttr newtype RoomMessage - = RoomMessageText MessageText - deriving (Show, Eq) + = RoomMessageText MessageText + deriving (Show, Eq) roomMessageAttr :: RoomMessage -> [Pair] roomMessageAttr rm = case rm of - RoomMessageText mt -> messageTextAttr mt + RoomMessageText mt -> messageTextAttr mt instance ToJSON RoomMessage where - toJSON msg = case msg of - RoomMessageText mt -> toJSON mt + toJSON msg = case msg of + RoomMessageText mt -> toJSON mt instance FromJSON RoomMessage where - parseJSON x = RoomMessageText <$> parseJSON x + parseJSON x = RoomMessageText <$> parseJSON x data RelatedMessage = RelatedMessage - { rmMessage :: RoomMessage, - rmRelatedTo :: EventID - } - deriving (Show, Eq) + { 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) + = 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 + 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 + 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 + EventRoomMessage _ -> "m.room.message" + EventRoomReply _ _ -> "m.room.message" + EventRoomEdit _ _ -> "m.room.message" + EventUnknown _ -> error $ "Event is not implemented: " <> show event newtype EventID = EventID {unEventID :: Text} deriving (Show, Eq, Ord) instance FromJSON EventID where - parseJSON (Object v) = EventID <$> v .: "event_id" - parseJSON _ = mzero + parseJSON (Object v) = EventID <$> v .: "event_id" + parseJSON _ = mzero instance ToJSON EventID where - toJSON (EventID v) = object ["event_id" .= v] + 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 @@ -2,10 +2,11 @@ {-# LANGUAGE OverloadedStrings #-} {-# LANGUAGE RecordWildCards #-} --- | This module contains the Identity service API --- https://matrix.org/docs/spec/identity_service/r0.3.0.html -module Network.Matrix.Identity - ( -- * Client +{- | This module contains the Identity service API +https://matrix.org/docs/spec/identity_service/r0.3.0.html +-} +module Network.Matrix.Identity ( + -- * Client IdentitySession, MatrixToken (..), getTokenFromEnv, @@ -33,14 +34,14 @@ mkIdentityLookupRequest, toHashedAddress, lookupIdentity, - ) +) where import Control.Monad (mzero) import Data.Aeson (FromJSON (..), Value (Object, String), encode, object, (.:), (.=)) import Data.Base64.Types (extractBase64) import Data.ByteString.Lazy (fromStrict) -import Data.ByteString.Lazy.Base64.URL (encodeBase64) +import Data.ByteString.Lazy.Base64.URL (encodeBase64Unpadded) import Data.Digest.Pure.SHA (bytestringDigest, sha256) #if MIN_VERSION_aeson(2,0,0) import qualified Data.Aeson.KeyMap as KeyMap @@ -63,111 +64,114 @@ toKVList = HM.toList #endif --- $setup --- >>> import Data.Aeson (decode) +{- $setup +>>> import Data.Aeson (decode) +-} -- | The session record, use 'createSession' to create it. data IdentitySession = IdentitySession - { baseUrl :: Text, - token :: MatrixToken, - manager :: HTTP.Manager - } + { baseUrl :: Text + , token :: MatrixToken + , manager :: HTTP.Manager + } -- | 'createSession' creates the session record. createIdentitySession :: - -- | The matrix identity base url, e.g. "https://matrix.org" - Text -> - -- | The user identity token - MatrixToken -> - IO IdentitySession + -- | The matrix identity base url, e.g. "https://matrix.org" + Text -> + -- | The user identity token + MatrixToken -> + IO IdentitySession createIdentitySession baseUrl' token' = IdentitySession baseUrl' token' <$> mkManager mkRequest :: IdentitySession -> Bool -> Text -> IO HTTP.Request -mkRequest IdentitySession {..} = mkRequest' baseUrl token +mkRequest IdentitySession{..} = mkRequest' baseUrl token -doRequest :: FromJSON a => IdentitySession -> HTTP.Request -> MatrixIO a -doRequest IdentitySession {..} = doRequest' manager +doRequest :: (FromJSON a) => IdentitySession -> HTTP.Request -> MatrixIO a +doRequest IdentitySession{..} = doRequest' manager -- | 'getIdentityTokenOwner' gets information about the owner of a given access token. getIdentityTokenOwner :: IdentitySession -> MatrixIO UserID getIdentityTokenOwner session = - doRequest session =<< mkRequest session True "/_matrix/identity/v2/account" + doRequest session =<< mkRequest session True "/_matrix/identity/v2/account" data HashDetails = HashDetails - { hdAlgorithms :: NonEmpty Text, - hdPepper :: Text - } - deriving (Show, Eq) + { hdAlgorithms :: NonEmpty Text + , hdPepper :: Text + } + deriving (Show, Eq) instance FromJSON HashDetails where - parseJSON (Object v) = HashDetails <$> v .: "algorithms" <*> v .: "lookup_pepper" - parseJSON _ = mzero + parseJSON (Object v) = HashDetails <$> v .: "algorithms" <*> v .: "lookup_pepper" + parseJSON _ = mzero hashDetails :: IdentitySession -> MatrixIO HashDetails hashDetails session = - doRequest session =<< mkRequest session True "/_matrix/identity/v2/hash_details" + doRequest session =<< mkRequest session True "/_matrix/identity/v2/hash_details" -- | Use 'identityLookup' to lookup a single identity, otherwise uses the full 'identitiesLookup'. identityLookup :: IdentitySession -> HashDetails -> Identity -> MatrixIO (Maybe UserID) identityLookup session hd ident = do - fmap toUserIDM <$> identitiesLookup session ilr + fmap toUserIDM <$> identitiesLookup session ilr where toUserIDM = lookupIdentity address address = toHashedAddress hd ident ilr = mkIdentityLookupRequest hd [address] data IdentityLookupRequest = IdentityLookupRequest - { ilrHash :: Text, - ilrPepper :: Text, - ilrAddresses :: [HashedAddress] - } - deriving (Show, Eq) + { ilrHash :: Text + , ilrPepper :: Text + , ilrAddresses :: [HashedAddress] + } + deriving (Show, Eq) newtype HashedAddress = HashedAddress Text deriving (Show, Eq) --- | A newtype wrapper to decoded nested list --- --- >>> decode "{\"mappings\": {\"hash\": \"user\"}}" :: Maybe IdentityLookupResponse --- Just (IdentityLookupResponse [(HashedAddress "hash",UserID "user")]) +{- | A newtype wrapper to decoded nested list + +>>> decode "{\"mappings\": {\"hash\": \"user\"}}" :: Maybe IdentityLookupResponse +Just (IdentityLookupResponse [(HashedAddress "hash",UserID "user")]) +-} newtype IdentityLookupResponse = IdentityLookupResponse [(HashedAddress, UserID)] - deriving (Show) + deriving (Show) instance FromJSON IdentityLookupResponse where - parseJSON (Object v) = do - mappings <- v .: "mappings" - case mappings of - (Object kv) -> pure . IdentityLookupResponse $ mapMaybe toTuple (toKVList kv) - _ -> mzero - where - toTuple (k, String s) = Just (HashedAddress k, UserID s) - toTuple _ = Nothing - parseJSON _ = mzero + parseJSON (Object v) = do + mappings <- v .: "mappings" + case mappings of + (Object kv) -> pure . IdentityLookupResponse $ mapMaybe toTuple (toKVList kv) + _ -> mzero + where + toTuple (k, String s) = Just (HashedAddress k, UserID s) + toTuple _ = Nothing + parseJSON _ = mzero identitiesLookup :: IdentitySession -> IdentityLookupRequest -> MatrixIO IdentityLookupResponse identitiesLookup session ilr = do - request <- mkRequest session True "/_matrix/identity/v2/lookup" - doRequest - session - ( request - { HTTP.method = "POST", - HTTP.requestBody = HTTP.RequestBodyLBS body - } - ) + request <- mkRequest session True "/_matrix/identity/v2/lookup" + doRequest + session + ( request + { HTTP.method = "POST" + , HTTP.requestBody = HTTP.RequestBodyLBS body + } + ) where getAddr (HashedAddress x) = x body = - encode $ - object - [ "addresses" .= map getAddr (ilrAddresses ilr), - "algorithm" .= ilrHash ilr, - "pepper" .= ilrPepper ilr - ] + encode $ + object + [ "addresses" .= map getAddr (ilrAddresses ilr) + , "algorithm" .= ilrHash ilr + , "pepper" .= ilrPepper ilr + ] --- | Hash encoding for lookup --- >>> encodeSHA256 "alice@example.com email matrixrocks" --- "4kenr7N9drpCJ4AfalmlGQVsOn3o2RHjkADUpXJWZUc" +{- | Hash encoding for lookup +>>> encodeSHA256 "alice@example.com email matrixrocks" +"4kenr7N9drpCJ4AfalmlGQVsOn3o2RHjkADUpXJWZUc" +-} encodeSHA256 :: Text -> Text -encodeSHA256 = toStrict . extractBase64 . encodeBase64 . bytestringDigest . sha256 . fromStrict . encodeUtf8 +encodeSHA256 = toStrict . extractBase64 . encodeBase64Unpadded . bytestringDigest . sha256 . fromStrict . encodeUtf8 data Identity = Email Text | Msisdn Text deriving (Show, Eq) @@ -175,16 +179,16 @@ toHashedAddress hd ident = HashedAddress $ encodeSHA256 $ val <> " " <> hdPepper hd where val = case ident of - Email x -> x <> " email" - Msisdn x -> x <> " msisdn" + Email x -> x <> " email" + Msisdn x -> x <> " msisdn" mkIdentityLookupRequest :: HashDetails -> [HashedAddress] -> IdentityLookupRequest mkIdentityLookupRequest hd = IdentityLookupRequest hash (hdPepper hd) where hash = - if "sha256" `elem` hdAlgorithms hd - then "sha256" - else error "Only sha256 is supported" + if "sha256" `elem` hdAlgorithms hd + then "sha256" + else error "Only sha256 is supported" lookupIdentity :: HashedAddress -> IdentityLookupResponse -> Maybe UserID lookupIdentity x (IdentityLookupResponse xs) = Data.List.lookup x xs 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 @@ -14,7 +14,7 @@ import Control.Monad.IO.Class (MonadIO, liftIO) import Control.Retry (RetryStatus (..)) import qualified Control.Retry as Retry -import Data.Aeson (FromJSON (..), FromJSONKey (..), Value (Object), encode, eitherDecode, object, withObject, (.:), (.:?), (.=)) +import Data.Aeson (FromJSON (..), FromJSONKey (..), Value (Object), eitherDecode, encode, object, withObject, (.:), (.:?), (.=)) import Data.ByteString.Lazy (ByteString, toStrict) import Data.Hashable (Hashable) import Data.Maybe (catMaybes, fromMaybe) @@ -29,30 +29,30 @@ import System.IO (stderr) newtype MatrixToken = MatrixToken Text -newtype Username = Username { username :: Text } -newtype DeviceId = DeviceId { deviceId :: Text } -newtype InitialDeviceDisplayName = InitialDeviceDisplayName { initialDeviceDisplayName :: Text} +newtype Username = Username {username :: Text} +newtype DeviceId = DeviceId {deviceId :: Text} +newtype InitialDeviceDisplayName = InitialDeviceDisplayName {initialDeviceDisplayName :: Text} data LoginSecret = Password Text | Token Text data LoginResponse = LoginResponse - { lrUserId :: Text - , lrAccessToken :: Text - , lrHomeServer :: Text - , lrDeviceId :: Text - } + { lrUserId :: Text + , lrAccessToken :: Text + , lrHomeServer :: Text + , lrDeviceId :: Text + } instance FromJSON LoginResponse where - parseJSON = withObject "LoginResponse" $ \v -> do - userId' <- v .: "user_id" - accessToken' <- v .: "access_token" - homeServer' <- v .: "home_server" - deviceId' <- v .: "device_id" - pure $ LoginResponse userId' accessToken' homeServer' deviceId' + parseJSON = withObject "LoginResponse" $ \v -> do + userId' <- v .: "user_id" + accessToken' <- v .: "access_token" + homeServer' <- v .: "home_server" + deviceId' <- v .: "device_id" + pure $ LoginResponse userId' accessToken' homeServer' deviceId' getTokenFromEnv :: - -- | The envirnoment variable name - Text -> - IO MatrixToken + -- | The envirnoment variable name + Text -> + IO MatrixToken getTokenFromEnv env = MatrixToken . pack <$> getEnv (unpack env) mkManager :: IO HTTP.Manager @@ -60,98 +60,104 @@ checkMatrixResponse :: HTTP.Request -> HTTP.Response HTTP.BodyReader -> IO () checkMatrixResponse req res = - unless (200 <= code && code < 500) $ do - chunk <- HTTP.brReadSome (HTTP.responseBody res) 1024 - throwResponseError req res chunk + unless (200 <= code && code < 500) $ do + chunk <- HTTP.brReadSome (HTTP.responseBody res) 1024 + throwResponseError req res chunk where Status code _ = HTTP.responseStatus res throwResponseError :: HTTP.Request -> HTTP.Response body -> ByteString -> IO a throwResponseError req res chunk = - throwIO $ HTTP.HttpExceptionRequest req ex + throwIO $ HTTP.HttpExceptionRequest req ex where ex = HTTP.StatusCodeException (void res) (toStrict chunk) mkRequest' :: Text -> MatrixToken -> Bool -> Text -> IO HTTP.Request mkRequest' baseUrl (MatrixToken token) auth path = do - initRequest <- HTTP.parseUrlThrow (unpack $ baseUrl <> path) - pure $ - initRequest - { HTTP.requestHeaders = - [("Content-Type", "application/json")] <> authHeaders, - HTTP.checkResponse = checkMatrixResponse - } + initRequest <- HTTP.parseUrlThrow (unpack $ baseUrl <> path) + pure $ + initRequest + { HTTP.requestHeaders = + [("Content-Type", "application/json")] <> authHeaders + , HTTP.checkResponse = checkMatrixResponse + } where authHeaders = - [("Authorization", "Bearer " <> encodeUtf8 token) | auth] + [("Authorization", "Bearer " <> encodeUtf8 token) | auth] mkLoginRequest' :: Text -> Maybe DeviceId -> Maybe InitialDeviceDisplayName -> Username -> LoginSecret -> IO HTTP.Request mkLoginRequest' baseUrl did idn (Username name) secret' = do - let path = "/_matrix/client/r0/login" - initRequest <- HTTP.parseUrlThrow (unpack $ baseUrl <> path) + let path = "/_matrix/client/r0/login" + initRequest <- HTTP.parseUrlThrow (unpack $ baseUrl <> path) - let (secretKey, secret, secretType) = case secret' of - Password pass -> ("password", pass, "m.login.password") - Token tok -> ("token", tok, "m.login.token") + let (secretKey, secret, secretType) = case secret' of + Password pass -> ("password", pass, "m.login.password") + Token tok -> ("token", tok, "m.login.token") - let body = HTTP.RequestBodyLBS $ encode $ object $ - [ "identifier" .= object [ "type" .= ("m.id.user" :: Text), "user" .= name ] - , secretKey .= secret - , "type" .= (secretType :: Text) - ] <> catMaybes [ fmap (("device_id" .=) . deviceId) did - , fmap (("initial_device_display_name" .=) . initialDeviceDisplayName) idn - ] + let body = + HTTP.RequestBodyLBS $ + encode $ + object $ + [ "identifier" .= object ["type" .= ("m.id.user" :: Text), "user" .= name] + , secretKey .= secret + , "type" .= (secretType :: Text) + ] + <> catMaybes + [ fmap (("device_id" .=) . deviceId) did + , fmap (("initial_device_display_name" .=) . initialDeviceDisplayName) idn + ] - pure $ initRequest { HTTP.method = "POST", HTTP.requestBody = body, HTTP.requestHeaders = [("Content-Type", "application/json")] } + pure $ initRequest{HTTP.method = "POST", HTTP.requestBody = body, HTTP.requestHeaders = [("Content-Type", "application/json")]} mkLogoutRequest' :: Text -> MatrixToken -> IO HTTP.Request mkLogoutRequest' baseUrl (MatrixToken token) = do - let path = "/_matrix/client/r0/logout" - initRequest <- HTTP.parseUrlThrow (unpack $ baseUrl <> path) - let headers = [("Authorization", encodeUtf8 $ "Bearer " <> token)] - pure $ initRequest { HTTP.method = "POST", HTTP.requestHeaders = headers } + let path = "/_matrix/client/r0/logout" + initRequest <- HTTP.parseUrlThrow (unpack $ baseUrl <> path) + let headers = [("Authorization", encodeUtf8 $ "Bearer " <> token)] + pure $ initRequest{HTTP.method = "POST", HTTP.requestHeaders = headers} -doRequest' :: FromJSON a => HTTP.Manager -> HTTP.Request -> IO (Either MatrixError a) +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 - Right x -> pure x - Left e -> if statusIsSuccessful $ HTTP.responseStatus response - then fail e - else throwResponseError request response (HTTP.responseBody response) + response <- HTTP.httpLbs request manager + 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 -> Either String (Either MatrixError a) +decodeResp :: (FromJSON a) => ByteString -> Either String (Either MatrixError a) decodeResp resp = case eitherDecode resp of - Right a -> Right $ pure a - Left e -> case eitherDecode resp of - Right me -> Right $ Left me - Left _ -> Left e + 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, Ord, Hashable, FromJSONKey) + deriving (Show, Eq, Ord, Hashable, FromJSONKey) instance FromJSON UserID where - parseJSON (Object v) = UserID <$> v .: "user_id" - parseJSON _ = mzero + parseJSON (Object v) = UserID <$> v .: "user_id" + parseJSON _ = mzero data MatrixError = MatrixError - { meErrcode :: Text, - meError :: Text, - meRetryAfterMS :: Maybe Int - } - deriving (Show, Eq) + { meErrcode :: Text + , meError :: Text + , meRetryAfterMS :: Maybe Int + } + deriving (Show, Eq) data MatrixException = MatrixRateLimit deriving (Show) instance Exception MatrixException instance FromJSON MatrixError where - parseJSON (Object v) = - MatrixError - <$> v .: "errcode" - <*> v .: "error" - <*> v .:? "retry_after_ms" - parseJSON _ = mzero + parseJSON (Object v) = + MatrixError + <$> v .: "errcode" + <*> v .: "error" + <*> v .:? "retry_after_ms" + parseJSON _ = mzero -- | 'MatrixIO' is a convenient type alias for server response type MatrixIO a = MatrixM IO a @@ -160,48 +166,48 @@ -- | 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 + (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] - (const checkAction) + Retry.recovering + (Retry.exponentialBackoff backoff <> Retry.limitRetries limit) + [handler, rateLimitHandler] + (const checkAction) where checkAction = do - res <- action - case res of - Left (MatrixError "M_LIMIT_EXCEEDED" err delayMS) -> do - -- Reponse contains a retry_after_ms - logRetry $ "RateLimit: " <> err <> " (delay: " <> pack (show delayMS) <> ")" - liftIO $ threadDelay $ fromMaybe 5_000 delayMS * 1000 - throw MatrixRateLimit - _ -> pure res + res <- action + case res of + Left (MatrixError "M_LIMIT_EXCEEDED" err delayMS) -> do + -- Reponse contains a retry_after_ms + logRetry $ "RateLimit: " <> err <> " (delay: " <> pack (show delayMS) <> ")" + liftIO $ threadDelay $ fromMaybe 5_000 delayMS * 1000 + throw MatrixRateLimit + _ -> pure res - backoff = 1000000 -- 1sec + backoff = 1_000_000 -- 1sec rateLimitHandler _ = Handler $ \case - MatrixRateLimit -> pure True + MatrixRateLimit -> pure True -- Log network error handler (RetryStatus num _ _) = Handler $ \case - HTTP.HttpExceptionRequest req ctx -> do - let url = decodeUtf8 (HTTP.host req) <> ":" <> pack (show (HTTP.port req)) <> decodeUtf8 (HTTP.path req) - arg = decodeUtf8 $ HTTP.queryString req - loc = if num == 0 then url <> arg else url - logRetry $ - "NetworkFailure: " - <> pack (show num) - <> "/5 " - <> loc - <> " failed: " - <> pack (show ctx) - pure True - HTTP.InvalidUrlException _ _ -> pure False + HTTP.HttpExceptionRequest req ctx -> do + let url = decodeUtf8 (HTTP.host req) <> ":" <> pack (show (HTTP.port req)) <> decodeUtf8 (HTTP.path req) + arg = decodeUtf8 $ HTTP.queryString req + loc = if num == 0 then url <> arg else url + logRetry $ + "NetworkFailure: " + <> pack (show num) + <> "/5 " + <> loc + <> " failed: " + <> pack (show ctx) + pure True + HTTP.InvalidUrlException _ _ -> pure False retry :: (MonadIO m, MonadMask m) => MatrixM m a -> MatrixM m a retry = retryWithLog 7 (liftIO . hPutStrLn stderr) diff --git a/src/Network/Matrix/Room.hs b/src/Network/Matrix/Room.hs --- a/src/Network/Matrix/Room.hs +++ b/src/Network/Matrix/Room.hs @@ -12,24 +12,24 @@ -- | https://matrix.org/docs/spec/client_server/latest#post-matrix-client-r0-createroom data RoomCreatePreset - = PrivateChat - | TrustedPrivateChat - | PublicChat - deriving (Eq, Show) + = 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" + 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) + { rcrPreset :: RoomCreatePreset + , rcrRoomAliasName :: Text + , rcrName :: Text + , rcrTopic :: Text + } + deriving (Eq, Show, Generic) instance ToJSON RoomCreateRequest where - toJSON = genericToJSON $ (aesonPrefix snakeCase) {Aeson.omitNothingFields = True} + 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 @@ -1,22 +1,23 @@ --- | The @matrix-client@ library provides a simple interface for interacting with Matrix servers. --- --- This tutorial introduces how to use the @matrix-client@ library. --- --- You will need a token to create a session, if you already have an account, you can get it with the @element@ client --- by visiting the account @Settings@ page, @Help & About@ panel, then click @Access Token@. --- --- Alternatively, you can setup a test service by running these commands in a terminal: --- --- > git clone https://github.com/matrix-org/dendrite --- > cd dendrite; ./build.sh; ./bin/generate-keys --private-key matrix_key.pem; cp dendrite-config.yaml dendrite.yaml --- > ./bin/dendrite-monolith-server --config dendrite.yaml --- > curl -XPOST http://localhost:8008/_matrix/client/r0/register -d'{"username": "tristanC", "password": "supersecret", "auth": {"type": "m.login.dummy"}}' --- --- To avoid manipulating the token directly, put it in your environment: --- --- > export MATRIX_TOKEN="THE_ACCESS_TOKEN" -module Network.Matrix.Tutorial - ( -- * Introduction +{- | The @matrix-client@ library provides a simple interface for interacting with Matrix servers. + +This tutorial introduces how to use the @matrix-client@ library. + +You will need a token to create a session, if you already have an account, you can get it with the @element@ client +by visiting the account @Settings@ page, @Help & About@ panel, then click @Access Token@. + +Alternatively, you can setup a test service by running these commands in a terminal: + +> git clone https://github.com/matrix-org/dendrite +> cd dendrite; ./build.sh; ./bin/generate-keys --private-key matrix_key.pem; cp dendrite-config.yaml dendrite.yaml +> ./bin/dendrite-monolith-server --config dendrite.yaml +> curl -XPOST http://localhost:8008/_matrix/client/r0/register -d'{"username": "tristanC", "password": "supersecret", "auth": {"type": "m.login.dummy"}}' + +To avoid manipulating the token directly, put it in your environment: + +> export MATRIX_TOKEN="THE_ACCESS_TOKEN" +-} +module Network.Matrix.Tutorial ( + -- * Introduction -- $intro -- * Create a session @@ -27,90 +28,94 @@ -- * Lookup identity -- $identity - ) +) where --- $intro --- To start using this library you need a haskell toolchain, on fedora run: --- --- > $ sudo dnf install -y ghc cabal-install && cabal update --- --- Then get a copy of the library by running: --- --- > $ git clone https://github.com/softwarefactory-project/matrix-client-haskell --- > $ cd matrix-client-haskell --- --- Start a REPL: --- --- > $ cabal repl --- > Prelude> import Network.Matrix.Client --- > Prelude Netowrk.Matrix.Client> :set prompt "> " --- > > :set -XOverloadedStrings --- > > :type getTokenOwner --- > getTokenOwner :: ClientSession -> MatrixIO WhoAmI +{- $intro + To start using this library you need a haskell toolchain, on fedora run: --- $session --- 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 'Network.Matrix.Client.createSession' function: --- --- > > token <- getTokenFromEnv "MATRIX_TOKEN" --- > > sess <- createSession "https://matrix.org" token --- > > getTokenOwner sess --- > Right (WhoAmI "@tristanc_:matrix.org") + > $ sudo dnf install -y ghc cabal-install && cabal update --- $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! --- > ... + Then get a copy of the library by running: --- $identity --- To use the Identity api you need another token. Get it by running these commands: --- --- > $ MATRIX_OPENID=$(curl -XPOST https://matrix.org/_matrix/client/r0/user/${USER}/openid/request_token -H "Authorization: Bearer ${MATRIX_TOKEN}" -d '{}') --- > $ export MATRIX_IDENTITY_TOKEN=$(curl -XPOST https://matrix.org/_matrix/identity/v2/account/register -d "${MATRIX_OPENID}" | jq -r '.access_token') --- --- Then here is how to lookup a matrix identity: --- --- > > import Network.Matrix.Identity --- > > tokenId <- getTokenFromEnv "MATRIX_IDENTITY_TOKEN" --- > > sessId <- createIdentitySession "https://matrix.org" tokenId --- > > Right hd <- hashDetails sessId --- > > identityLookup sessId hd (Email "tdecacqu@redhat.com") --- > Right (Just (UserID "@tristanc_:matrix.org")) + > $ git clone https://github.com/softwarefactory-project/matrix-client-haskell + > $ cd matrix-client-haskell + + Start a REPL: + + > $ cabal repl + > Prelude> import Network.Matrix.Client + > Prelude Netowrk.Matrix.Client> :set prompt "> " + > > :set -XOverloadedStrings + > > :type getTokenOwner + > getTokenOwner :: ClientSession -> MatrixIO WhoAmI +-} + +{- $session + 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 '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: + + > $ MATRIX_OPENID=$(curl -XPOST https://matrix.org/_matrix/client/r0/user/${USER}/openid/request_token -H "Authorization: Bearer ${MATRIX_TOKEN}" -d '{}') + > $ export MATRIX_IDENTITY_TOKEN=$(curl -XPOST https://matrix.org/_matrix/identity/v2/account/register -d "${MATRIX_OPENID}" | jq -r '.access_token') + + Then here is how to lookup a matrix identity: + + > > import Network.Matrix.Identity + > > tokenId <- getTokenFromEnv "MATRIX_IDENTITY_TOKEN" + > > sessId <- createIdentitySession "https://matrix.org" tokenId + > > Right hd <- hashDetails sessId + > > identityLookup sessId hd (Email "tdecacqu@redhat.com") + > Right (Just (UserID "@tristanc_:matrix.org")) +-} diff --git a/test/Spec.hs b/test/Spec.hs --- a/test/Spec.hs +++ b/test/Spec.hs @@ -17,112 +17,112 @@ main :: IO () 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) + 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 room) -> room `shouldSatisfy` (/= mempty) - it "join room" $ do - resp <- joinRoom sess1 "#test:localhost" - case resp of - Left err -> error (show err) - Right (RoomID room) -> room `shouldSatisfy` (/= mempty) - resp' <- joinRoom sess2 "#test:localhost" - case resp' of - Left err -> error (show err) - Right (RoomID room) -> room `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 + 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 room) -> room `shouldSatisfy` (/= mempty) + it "join room" $ do + resp <- joinRoom sess1 "#test:localhost" + case resp of + Left err -> error (show err) + Right (RoomID room) -> room `shouldSatisfy` (/= mempty) + resp' <- joinRoom sess2 "#test:localhost" + case resp' of + Left err -> error (show err) + Right (RoomID room) -> room `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 - it "invite private room" $ do - Right room <- createRoom sess1 $ RoomCreateRequest PrivateChat "private" "private-test" "A test" - Right user <- getTokenOwner sess2 - Right inviteResult <- inviteToRoom sess1 room user (Just "Welcome!") - inviteResult `shouldBe` () + it "invite private room" $ do + Right room <- createRoom sess1 $ RoomCreateRequest PrivateChat "private" "private-test" "A test" + Right user <- getTokenOwner sess2 + Right inviteResult <- inviteToRoom sess1 room user (Just "Welcome!") + inviteResult `shouldBe` () spec :: Spec spec = describe "unit tests" $ do - it "decode unknown" $ - (decodeResp "" :: Either String (Either MatrixError String)) - `shouldSatisfy` isLeft - it "decode error" $ - (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` (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" TextType Nothing Nothing)) - `shouldBe` "{\"body\":\"Hello\",\"msgtype\":\"m.text\"}" - it "does not retry on success" $ - checkPause (<=) $ do - let resp = Right True - res <- retry (pure resp) - res `shouldBe` resp - it "does not retry on regular failre" $ - checkPause (<=) $ do - let resp = Left $ MatrixError "test" "error" Nothing - res <- (retry (pure resp) :: MatrixIO Int) - res `shouldBe` resp - it "retry on rate limit failure" $ - checkPause (>=) $ do - let resp = Left $ MatrixError "M_LIMIT_EXCEEDED" "error" (Just 1000) - (retryWithLog 1 (const $ pure ()) (pure resp) :: MatrixIO Int) - `shouldThrow` rateLimitSelector + it "decode unknown" $ + (decodeResp "" :: Either String (Either MatrixError String)) + `shouldSatisfy` isLeft + it "decode error" $ + (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` (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" TextType Nothing Nothing)) + `shouldBe` "{\"body\":\"Hello\",\"msgtype\":\"m.text\"}" + it "does not retry on success" $ + checkPause (<=) $ do + let resp = Right True + res <- retry (pure resp) + res `shouldBe` resp + it "does not retry on regular failre" $ + checkPause (<=) $ do + let resp = Left $ MatrixError "test" "error" Nothing + res <- (retry (pure resp) :: MatrixIO Int) + res `shouldBe` resp + it "retry on rate limit failure" $ + checkPause (>=) $ do + let resp = Left $ MatrixError "M_LIMIT_EXCEEDED" "error" (Just 1000) + (retryWithLog 1 (const $ pure ()) (pure resp) :: MatrixIO Int) + `shouldThrow` rateLimitSelector where rateLimitSelector :: MatrixException -> Bool rateLimitSelector MatrixRateLimit = True checkPause op action = do - MkSystemTime startTS _ <- getSystemTime - void action - MkSystemTime endTS _ <- getSystemTime - (endTS - startTS) `shouldSatisfy` (`op` 1) + MkSystemTime startTS _ <- getSystemTime + void action + MkSystemTime endTS _ <- getSystemTime + (endTS - startTS) `shouldSatisfy` (`op` 1) encodePretty = - Aeson.encodePretty' - ( Aeson.defConfig {Aeson.confIndent = Aeson.Spaces 0, Aeson.confCompare = compare @Text} - ) + Aeson.encodePretty' + ( Aeson.defConfig{Aeson.confIndent = Aeson.Spaces 0, Aeson.confCompare = compare @Text} + )