matrix-client 0.1.6.0 → 0.1.6.1
raw patch · 10 files changed
+2130/−2046 lines, 10 filesdep ~base64dep ~hashablePVP ok
version bump matches the API change (PVP)
Dependency ranges changed: base64, hashable
API changes (from Hackage documentation)
Files
- CHANGELOG.md +4/−0
- matrix-client.cabal +88/−75
- src/Network/Matrix/Client.hs +1371/−1320
- src/Network/Matrix/Client/Lens.hs +162/−161
- src/Network/Matrix/Events.hs +98/−98
- src/Network/Matrix/Identity.hs +75/−71
- src/Network/Matrix/Internal.hs +114/−108
- src/Network/Matrix/Room.hs +15/−15
- src/Network/Matrix/Tutorial.hs +106/−101
- test/Spec.hs +97/−97
CHANGELOG.md view
@@ -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
matrix-client.cabal view
@@ -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,
src/Network/Matrix/Client.hs view
@@ -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--- <room id>, <event type> and <state key> 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"--- "> <foo@matrix.org> Hello\n\nhi"------ >>> addReplyBody sender "" "hey"--- "> <foo@matrix.org>\n\nhey"------ >>> addReplyBody sender "a multi\nline" "resp"--- "> <foo@matrix.org> 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- [ "<mx-reply>",- " <blockquote>",- " <a href=\"https://matrix.to/#/" <> roomID <> "/" <> eventID <> "\">In reply to</a>",- " <a href=\"https://matrix.to/#/" <> author <> "\">" <> author <> "</a>",- " <br />",- " " <> old,- " </blockquote>",- "</mx-reply>",- reply- ]---- | Convert body by encoding HTML special char------ >>> toFormattedBody "& <test>"--- "& <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+<room id>, <event type> and <state key> 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"+"> <foo@matrix.org> Hello\n\nhi"++>>> addReplyBody sender "" "hey"+"> <foo@matrix.org>\n\nhey"++>>> addReplyBody sender "a multi\nline" "resp"+"> <foo@matrix.org> 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+ [ "<mx-reply>"+ , " <blockquote>"+ , " <a href=\"https://matrix.to/#/" <> roomID <> "/" <> eventID <> "\">In reply to</a>"+ , " <a href=\"https://matrix.to/#/" <> author <> "\">" <> author <> "</a>"+ , " <br />"+ , " " <> old+ , " </blockquote>"+ , "</mx-reply>"+ , reply+ ]++{- | Convert body by encoding HTML special char++>>> toFormattedBody "& <test>"+"& <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
src/Network/Matrix/Client/Lens.hs view
@@ -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}
src/Network/Matrix/Events.hs view
@@ -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]
src/Network/Matrix/Identity.hs view
@@ -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
src/Network/Matrix/Internal.hs view
@@ -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)
src/Network/Matrix/Room.hs view
@@ -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}
src/Network/Matrix/Tutorial.hs view
@@ -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"))+-}
test/Spec.hs view
@@ -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}+ )