diff --git a/matrix-client/src/Network/Matrix/Client.hs b/matrix-client/src/Network/Matrix/Client.hs index beb2875..7db32dd 100644 --- a/matrix-client/src/Network/Matrix/Client.hs +++ b/matrix-client/src/Network/Matrix/Client.hs @@ -137,7 +137,7 @@ module Network.Matrix.Client ) where -import Control.Monad (mzero, void) +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 @@ -200,9 +200,9 @@ mkLogoutRequest ClientSession {..} = mkLogoutRequest' baseUrl token -- | 'logout' allows you to destroy a session token. logout :: ClientSession -> MatrixIO () -logout session@ClientSession {..} = do +logout session = do req <- mkLogoutRequest session - fmap (() <$) $ doRequest' @Value manager req + doRequestExpectEmptyResponse session "logout" req -- | The session record, use 'createSession' to create it. data ClientSession = ClientSession @@ -226,6 +226,16 @@ 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 = @@ -568,17 +578,17 @@ resolveRoomAlias session r@(RoomAlias alias) = do setRoomAlias :: ClientSession -> RoomAlias -> RoomID -> MatrixIO () setRoomAlias session (RoomAlias alias) (RoomID roomId)= do request <- mkRequest session True $ "/_matrix/client/v3/directory/room/" <> escapeUriComponent alias - doRequest - session $ + 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 - doRequest session $ request { HTTP.method = "DELETE" } + doRequestExpectEmptyResponse session "delete room alias" $ request { HTTP.method = "DELETE" } data ResolvedAliases = ResolvedAliases [RoomAlias] @@ -631,7 +641,7 @@ 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] - doRequest session $ + doRequestExpectEmptyResponse session "invite" $ request { HTTP.method = "POST" , HTTP.requestBody = HTTP.RequestBodyLBS $ encode body } @@ -671,25 +681,14 @@ knockOnRoom session room servers reason = do forgetRoom :: ClientSession -> RoomID -> MatrixIO () forgetRoom session (RoomID roomId) = do request <- mkRequest session True $ "/_matrix/client/v3/rooms/" <> roomId <> "/forget" - fmap ensureEmptyObject <$> doRequest session (request {HTTP.method = "POST"}) - where - ensureEmptyObject :: Value -> () - ensureEmptyObject value = case value of - Object xs | xs == mempty -> () - _anyOther -> error $ "Unknown forget response: " <> show value - + 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" - fmap ensureEmptyObject <$> doRequest session (request {HTTP.method = "POST"}) - where - ensureEmptyObject :: Value -> () - ensureEmptyObject value = case value of - Object xs | xs == mempty -> () - _anyOther -> error $ "Unknown leave response: " <> show value + doRequestExpectEmptyResponse session "leave" (request {HTTP.method = "POST"}) -- | Kick a user from the room. -- https://spec.matrix.org/v1.1/client-server-api/#post_matrixclientv3roomsroomidkick @@ -697,15 +696,10 @@ 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] - fmap (fmap ensureEmptyObject) $ doRequest session $ + doRequestExpectEmptyResponse session "kick" $ request { HTTP.method = "POST" , HTTP.requestBody = HTTP.RequestBodyLBS $ encode body } - where - ensureEmptyObject :: Value -> () - ensureEmptyObject value = case value of - Object xs | xs == mempty -> () - _anyOther -> error $ "Unknown leave response: " <> show value -- | 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 @@ -713,15 +707,10 @@ 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] - fmap (fmap ensureEmptyObject) $ doRequest session $ + doRequestExpectEmptyResponse session "ban" $ request { HTTP.method = "POST" , HTTP.requestBody = HTTP.RequestBodyLBS $ encode body } - where - ensureEmptyObject :: Value -> () - ensureEmptyObject value = case value of - Object xs | xs == mempty -> () - _anyOther -> error $ "Unknown leave response: " <> show value -- | 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 @@ -731,15 +720,10 @@ 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] - fmap (fmap ensureEmptyObject) $ doRequest session $ + doRequestExpectEmptyResponse session "unban" $ request { HTTP.method = "POST" , HTTP.requestBody = HTTP.RequestBodyLBS $ encode body } - where - ensureEmptyObject :: Value -> () - ensureEmptyObject value = case value of - Object xs | xs == mempty -> () - _anyOther -> error $ "Unknown leave response: " <> show value data Visibility = Public | Private deriving (Show) @@ -775,15 +759,10 @@ 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)] - fmap (fmap ensureEmptyObject) $ doRequest session $ + doRequestExpectEmptyResponse session "set room visibility" $ request { HTTP.method = "PUT" , HTTP.requestBody = HTTP.RequestBodyLBS $ encode body } - where - ensureEmptyObject :: Value -> () - ensureEmptyObject value = case value of - Object xs | xs == mempty -> () - _anyOther -> error $ "Unknown setRoomVisibility response: " <> show value -- | A pagination token from a previous request, allowing clients to -- get the next (or previous) batch of rooms. The direction of @@ -1310,11 +1289,10 @@ getAccountData' session userID t = setAccountData' :: (ToJSON a) => ClientSession -> UserID -> T.Text -> a -> MatrixIO () setAccountData' session userID t value = do request <- mkRequest session True $ accountDataPath userID t - void <$> (doRequest session $ request + doRequestExpectEmptyResponse session "set account data" $ request { HTTP.method = "PUT" , HTTP.requestBody = HTTP.RequestBodyLBS $ encode value - } :: MatrixIO Aeson.Object - ) + } accountDataPath :: UserID -> T.Text -> T.Text accountDataPath (UserID userID) t =